GIFImage 2.2 在 Delphi 6 下不能使用的情况修改
作者：wxz
此文最初出处在：www.51delphi.com
TGIFImage 是 Delphi 下优秀的 Gif 格式图片支持控件，可以对GIF动画播放、格式转换、动画GIF制作等等。
但是，在我的机器中安装了 Delphi 6 之后， TGIFImage 控件便不能使用了。因为我必须使用它，所以在一番折腾之后，勉强把它安装了上去。但这两天看到还有些朋友在网上问这个问题，所以把它单独写了出来，供大家参考。
1、 情况：
在应用程序中使用Image控件，Use GIFImage 单元，在Image装入图片时死机。如果这时在IDE中强制中断，会发现有个线程在一直死循环。
2、 检查：
查看死循环代码，它在使用 FindWindow函数查找一个叫‘TthreadWindow’的窗口，如果找到了，那么程序继续执行，否则一直循环。
3、 问题分析：
因为这里是线程中的代码，所以猜测它在模拟 Delphi 5中 Tthread 的Synchronize方法：当找到主线程窗口后，发送消息让主线程执行，做为两个线程的同步方案。下面是源代码：
procedure TThread.Synchronize(Method: TThreadMethod);
begin
FSynchronizeException := nil;
FMethod := Method;
SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self));
if Assigned(FSynchronizeException) then raise FSynchronizeException;
end;
但是在 Delphi 6 中，已经没有主线程窗口了。因为要向 Linux 移植，所以所有通过 SendMessage 等函数同步线程的方法已经被事件和关键区所代替，所以 GIFImage 在找主窗口时，再也找不到了。
procedure TThread.Synchronize(Method: TThreadMethod);
var
SyncProc: TSyncProc;
begin
if GetCurrentThreadID = MainThreadID then
Method
else
begin
{$IFDEF MSWINDOWS}
SyncProc.Signal := CreateEvent(nil, True, False, nil);
try
{$ENDIF}
{$IFDEF LINUX}
FillChar(SyncProc, SizeOf(SyncProc), 0); // This also initializes the cond_var
{$ENDIF}
EnterCriticalSection(ThreadLock);
try
FSynchronizeException := nil;
FMethod := Method;
SyncProc.Thread := Self;
SyncList.Add(@SyncProc);
ProcPosted := True;
if Assigned(WakeMainThread) then
WakeMainThread(Self);
{$IFDEF MSWINDOWS}
LeaveCriticalSection(ThreadLock);
try
WaitForSingleObject(SyncProc.Signal, INFINITE);
finally
EnterCriticalSection(ThreadLock);
end;
{$ENDIF}
{$IFDEF LINUX}
pthread_cond_wait(SyncProc.Signal, ThreadLock);
{$ENDIF}
finally
LeaveCriticalSection(ThreadLock);
end;
{$IFDEF MSWINDOWS}
finally
CloseHandle(SyncProc.Signal);
end;
{$ENDIF}
if Assigned(FSynchronizeException) then raise FSynchronizeException;
end;
end;
4、 解决办法：
按照常规，应该修改 GIFImage 的源代码，达到与Delphi 6 兼容。但是，我们只是要 GIFImage 正常运行。所以更简单的办法是将 Delphi 5 中的线程部分拷贝出来，拷贝时要注意，包括声明、实现、变量、初始化、终止等处。然后在GIFImage 单元的接口部分 Uses 部分的最后，加上 Delphi5Thread 单元即可，实际内容如下：
unit Delphi5Thread platform;
{
从 Borland 的源代码中剪切、修改。
wxz 2002.3 版权在 Borland 公司.
}
interface
uses
SysUtils, Windows, ActiveX, Classes;
type
{ TThread }
EThread = class(Exception);
TThreadMethod = procedure of object;
TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
tpTimeCritical);
TThread = class
private
FHandle: THandle;
FThreadID: THandle;
FTerminated: Boolean;
FSuspended: Boolean;
FFreeOnTerminate: Boolean;
FFinished: Boolean;
FReturnValue: Integer;
FOnTerminate: TNotifyEvent;
FMethod: TThreadMethod;
FSynchronizeException: TObject;
procedure CallOnTerminate;
function GetPriority: TThreadPriority;
procedure SetPriority(Value: TThreadPriority);
procedure SetSuspended(Value: Boolean);
protected
procedure DoTerminate; virtual;
procedure Execute; virtual; abstract;
procedure Synchronize(Method: TThreadMethod);
property ReturnValue: Integer read FReturnValue write FReturnValue;
property Terminated: Boolean read FTerminated;
public
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
procedure Resume;
procedure Suspend;
procedure Terminate;
function WaitFor: LongWord;
property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
property Handle: THandle read FHandle;
property Priority: TThreadPriority read GetPriority write SetPriority;
property Suspended: Boolean read FSuspended write SetSuspended;
property ThreadID: THandle read FThreadID;
property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
end;
implementation
{ Thread management routines }
const
CM_EXECPROC = $8FFF;
CM_DESTROYWINDOW = $8FFE;
type
PRaiseFrame = ^TRaiseFrame;
TRaiseFrame = record
NextRaise: PRaiseFrame;
ExceptAddr: Pointer;
ExceptObject: TObject;
ExceptionRecord: PExceptionRecord;
end;
var
ThreadLock: TRTLCriticalSection;
ThreadWindow: HWND;
ThreadCount: Integer;
procedure FreeThreadWindow;
begin
if ThreadWindow <> 0 then
begin
DestroyWindow(ThreadWindow);
ThreadWindow := 0;
end;
end;
function ThreadWndProc(Window: HWND; Message, wParam, lParam: Longint): Longint; stdcall;
begin
case Message of
CM_EXECPROC:
with TThread(lParam) do
begin
Result := 0;
try
FSynchronizeException := nil;
FMethod;
except
if RaiseList <> nil then
begin
FSynchronizeException := PRaiseFrame(RaiseList)^.ExceptObject;
PRaiseFrame(RaiseList)^.ExceptObject := nil;
end;
end;
end;
CM_DESTROYWINDOW:
begin
EnterCriticalSection(ThreadLock);
try
Dec(ThreadCount);
if ThreadCount = 0 then
FreeThreadWindow;
finally
LeaveCriticalSection(ThreadLock);
end;
Result := 0;
end;
else
Result := DefWindowProc(Window, Message, wParam, lParam);
end;
end;
var
ThreadWindowClass: TWndClass = (
style: 0;
lpfnWndProc: @ThreadWndProc;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: 'TThreadWindow');
procedure AddThread;
function AllocateWindow: HWND;
var
TempClass: TWndClass;
ClassRegistered: Boolean;
begin
ThreadWindowClass.hInstance := HInstance;
ClassRegistered := GetClassInfo(HInstance, ThreadWindowClass.lpszClassName,
TempClass);
if not ClassRegistered or (TempClass.lpfnWndProc <> @ThreadWndProc) then
begin
if ClassRegistered then
Windows.UnregisterClass(ThreadWindowClass.lpszClassName, HInstance);
Windows.RegisterClass(ThreadWindowClass);
end;
Result := CreateWindow(ThreadWindowClass.lpszClassName, '', 0,
0, 0, 0, 0, 0, 0, HInstance, nil);
end;
begin
EnterCriticalSection(ThreadLock);
try
if ThreadCount = 0 then
ThreadWindow := AllocateWindow;
Inc(ThreadCount);
finally
LeaveCriticalSection(ThreadLock);
end;
end;
procedure RemoveThread;
begin
EnterCriticalSection(ThreadLock);
try
if ThreadCount = 1 then
PostMessage(ThreadWindow, CM_DESTROYWINDOW, 0, 0);
finally
LeaveCriticalSection(ThreadLock);
end;
end;
{ TThread }
function ThreadProc(Thread: TThread): Integer;
var
FreeThread: Boolean;
begin
try
Thread.Execute;
finally
FreeThread := Thread.FFreeOnTerminate;
Result := Thread.FReturnValue;
Thread.FFinished := True;
Thread.DoTerminate;
if FreeThread then Thread.Free;
EndThread(Result);
end;
end;
constructor TThread.Create(CreateSuspended: Boolean);
var
Flags: DWORD;
begin
inherited Create;
AddThread;
FSuspended := CreateSuspended;
Flags := 0;
if CreateSuspended then Flags := CREATE_SUSPENDED;
FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), Flags, FThreadID);
end;
destructor TThread.Destroy;
begin
if not FFinished and not Suspended then
begin
Terminate;
WaitFor;
end;
if FHandle <> 0 then CloseHandle(FHandle);
inherited Destroy;
RemoveThread;
end;
procedure TThread.CallOnTerminate;
begin
if Assigned(FOnTerminate) then FOnTerminate(Self);
end;
procedure TThread.DoTerminate;
begin
if Assigned(FOnTerminate) then Synchronize(CallOnTerminate);
end;
const
Priorities: array [TThreadPriority] of Integer =
(THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
function TThread.GetPriority: TThreadPriority;
var
P: Integer;
I: TThreadPriority;
begin
P := GetThreadPriority(FHandle);
Result := tpNormal;
for I := Low(TThreadPriority) to High(TThreadPriority) do
if Priorities = P then Result := I;
end;
procedure TThread.SetPriority(Value: TThreadPriority);
begin
SetThreadPriority(FHandle, Priorities[Value]);
end;
procedure TThread.Synchronize(Method: TThreadMethod);
begin
FSynchronizeException := nil;
FMethod := Method;
SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self));
if Assigned(FSynchronizeException) then raise FSynchronizeException;
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then
Suspend else
Resume;
end;
procedure TThread.Suspend;
begin
FSuspended := True;
SuspendThread(FHandle);
end;
procedure TThread.Resume;
begin
if ResumeThread(FHandle) = 1 then FSuspended := False;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: LongWord;
var
Msg: TMsg;
H: THandle;
begin
H := FHandle;
if GetCurrentThreadID = MainThreadID then
while MsgWaitForMultipleObjects(1, H, False, INFINITE,
QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
else WaitForSingleObject(H, INFINITE);
GetExitCodeThread(H, Result);
end;
initialization
InitializeCriticalSection(ThreadLock);
finalization
FreeThreadWindow;
DeleteCriticalSection(ThreadLock);
end.
]
][