本例是把多个线程访问数据库的请求，全部阻塞到一个线程。
这是实际编程中常见的一种问题。
示例源码下载，所需支持单元均在源码中，且附详细说明。
TElegantThread 的父类是 TSimpleThread。
unit uElegantThread; interface uses
Classes, SysUtils, uSimpleThread, uSimpleList, uSyncObjs; type PSyncRec = ^TSyncRec; TSyncRec = record
FMethod: TThreadMethod;
FProcedure: TThreadProcedure;
FSignal: TSuperEvent;
Queued: boolean;
DebugInfo: string;
end; TSyncRecList = Class(TSimpleList<PSyncRec>)
protected
procedure FreeItem(Item: PSyncRec); override;
End; TElegantThread = class(TSimpleThread)
private
FSyncRecList: TSyncRecList; procedure LockList;
procedure UnlockList; procedure Check;
procedure DoCheck; public // AAllowedActiveX 允许此线程访问 COM 如：IE ,
// 当然，获取 Ie 的 IHtmlDocument2 接口，也必须在此线程内执行
constructor Create(AAllowedActiveX: boolean = false);
destructor Destroy; override; // ADebugInfo 是调用者用来查错用，一般可以写上过程名 如：'DoSomeThing';
procedure Queue(AMethod: TThreadMethod; ADebugInfo: string = ''); overload;
procedure Queue(AProcedure: TThreadProcedure; ADebugInfo: string = ''); overload; procedure Synchronize(AMethod: TThreadMethod; ADebugInfo: string = ''); overload;
procedure Synchronize(AProcedure: TThreadProcedure; ADebugInfo: string = ''); overload; end; implementation { TSyncRecList } procedure TSyncRecList.FreeItem(Item: PSyncRec);
begin
inherited;
if Assigned(Item.FSignal) then
Item.FSignal.Free;
Dispose(Item);
end; { TElegantThread } procedure TElegantThread.Check;
begin
ExeProcInThread(DoCheck);
end; constructor TElegantThread.Create(AAllowedActiveX: boolean);
begin
inherited;
FSyncRecList := TSyncRecList.Create;
end; destructor TElegantThread.Destroy;
begin
WaitThreadStop;
FSyncRecList.Free;
inherited;
end; procedure TElegantThread.DoCheck;
var
p: PSyncRec;
sErrMsg: string;
begin LockList;
try
p := FSyncRecList.PopFirst; // 每次从 List 取出一个过程来执行
finally
UnlockList;
end; if Assigned(p) then
begin try if Assigned(p.FMethod) then
p.FMethod // 执行
else if Assigned(p.FProcedure) then
p.FProcedure(); // 执行 except
on E: Exception do // 错误处理
begin
sErrMsg := 'DebugInfo:' + p.DebugInfo + ##;
sErrMsg := sErrMsg + 'ErrMsg:' + E.Message;
DoOnDebugMsg(sErrMsg);
end;
end; if not p.Queued then // 如果是阻塞，请设为有信号，调用者即可返回
begin
p.FSignal.SetEvent;
end; Dispose(p);
Check; // 继续下一次 DoCheck,也就是本过程。
// 父类 TSimpleThread 已特殊处理，不会递归。 end; end; procedure TElegantThread.LockList;
begin
FSyncRecList.Lock;
end; procedure TElegantThread.Queue(AMethod: TThreadMethod; ADebugInfo: string);
var
p: PSyncRec;
begin
// 此过程为排队执行 new(p);
p.FProcedure := nil;
p.FMethod := AMethod;
p.Queued := true; LockList;
try
FSyncRecList.Add(p); // 把要执行的过程加入 List
Check; // 启动线程
finally
UnlockList;
end; end; procedure TElegantThread.Queue(AProcedure: TThreadProcedure; ADebugInfo: string);
var
p: PSyncRec;
begin
new(p);
p.FProcedure := AProcedure;
p.FMethod := nil;
p.Queued := true;
LockList;
try
FSyncRecList.Add(p);
Check;
finally
UnlockList;
end;
end; procedure TElegantThread.Synchronize(AMethod: TThreadMethod; ADebugInfo: string);
var
p: PSyncRec;
o: TSuperEvent;
begin // 此过程为阻塞执行，即调用者必须等到此过程被执行完成才能返回 new(p); p.FProcedure := nil;
p.FMethod := AMethod;
p.Queued := false;
p.FSignal := TSuperEvent.Create; // 创建一个信号
p.FSignal.ResetEvent; // 清除信号
o := p.FSignal; LockList;
try
FSyncRecList.Add(p);
Check;
finally
UnlockList;
end; o.WaitFor; // 等待信号出现
o.Free; end; procedure TElegantThread.Synchronize(AProcedure: TThreadProcedure; ADebugInfo: string);
var
p: PSyncRec;
o: TSuperEvent;
begin
new(p); p.FProcedure := AProcedure;
p.FMethod := nil;
p.Queued := false;
p.FSignal := TSuperEvent.Create;
p.FSignal.ResetEvent;
o := p.FSignal; LockList;
try
FSyncRecList.Add(p);
Check;
finally
UnlockList;
end; o.WaitFor;
o.Free; end; procedure TElegantThread.UnlockList;
begin
FSyncRecList.Unlock;
end; end. uElegantThread.pas
http://www.cnblogs.com/lackey/p/4782777.html