Delphi线程同种的方法有很多种，除了常用的Synchronize方法，也可以使用SendMessage向主窗口发送消息，因为 SendMessage是阻塞的，可以达到同步的效果。主线程可以直接定义消息类型的procedure接收消息，也可以重写TControl类的 WndProc窗口过程，在窗口过程里面截取自己想要的消息。

Thread

{*******************************************************}

{ }

{ Delphi Thread Sample 5 }

{ Creation Date 2012.12.30 }

{ Created By: ming }

{ }

{*******************************************************}

unit unitWorkThread;

interface

uses

Classes,Windows, Messages, SysUtils, Graphics, StdCtrls;

type

TWorkThread = class(TThread)

private

{ Private declarations }

FEvent: HWND;

FMsg: string;

FMemo: TMemo;

FInterval,FTickTimes,FCount: Cardinal;

procedure doSyncProc1;

procedure syncOutputMsg;

procedure addLog(const msg: string); overload;

procedure addLog(const fmtStr:string; const params: array of const); overload;

procedure _sleep(millisecond:Cardinal);

protected

procedure Execute; override;

public

constructor Create(Suspend: boolean); overload;

constructor Create(Suspend: boolean; mmoOutput: TMemo); overload;

destructor Destroy; override;

private

FThreadPause,FThreadStop: Boolean;

procedure doSomething;

public

function ThreadStart: Boolean;

function ThreadPause: Boolean;

function ThreadStop: Boolean;

procedure ThreadTerminate;

public

MainFromHandle: HWND;

DoUpdateUI: procedure(const value: string) of object;

property Interval:Cardinal read FInterval write FInterval;

end;

const {0x0400 - 0x7FFF}

WM_UPDATE_UI1 = WM_USER + $1001;

WM_UPDATE_UI2 = WM_USER + $1002;

WM_UPDATE_UI3 = WM_USER + $1003;

var

WorkThread: TWorkThread;

implementation

{ TWorkThread }

constructor TWorkThread.Create(Suspend: boolean);

begin

inherited Create(Suspend);

FEvent := CreateEvent(nil,True,False,nil);

FreeOnTerminate := True;

FInterval := 1000;

end;

procedure TWorkThread.addLog(const msg: string);

begin

FMsg := msg;

Synchronize(syncOutputMsg);

end;

procedure TWorkThread.addLog(const fmtStr: string;

const params: array of const);

begin

FMsg := Format(fmtStr,params);

Synchronize(syncOutputMsg);

end;

constructor TWorkThread.Create(Suspend: boolean; mmoOutput: TMemo);

begin

inherited Create(Suspend);

FEvent := CreateEvent(nil,True,False,nil);

FreeOnTerminate := True;

FInterval := 1000;

FMemo := mmoOutput;

end;

destructor TWorkThread.Destroy;

begin

CloseHandle(FEvent);

inherited;

end;

procedure TWorkThread.doSomething;

begin

//addLog(FormatDateTime('c',now));

Inc(FCount);

FCount := FCount mod 100000;

SendMessage(MainFromHandle,WM_UPDATE_UI1,0,FCount);

SendMessage(MainFromHandle,WM_UPDATE_UI2,0,FCount);

SendMessage(MainFromHandle,WM_UPDATE_UI3,0,FCount);

// doSyncProc1;

end;

procedure TWorkThread.doSyncProc1;

begin

DoUpdateUI(IntToStr(FCount));

end;

procedure TWorkThread.syncOutputMsg;

var

dt: string;

begin

dt := FormatDateTime('hh:nn:ss',now);

FMsg := Format('[%s] - ',[dt]) + FMsg;

if Assigned(FMemo) then

FMemo.Lines.Add(FMsg);

end;

procedure TWorkThread.Execute;

begin

inherited;

while not Terminated do

begin

if WaitForSingleObject(FEvent,100)=WAIT_OBJECT_0 then

begin

Break;

end;

if (GetTickCount - FTickTimes) >= FInterval then

try

if not FThreadStop then

begin

doSomething;

FTickTimes := GetTickCount;

end;

except on e:Exception do

addLog(e.Message);

end;

if FThreadStop then

Suspend;

end;

end;

function TWorkThread.ThreadStart: Boolean;

begin

FThreadStop := False;

if Suspended then Resume;

end;

function TWorkThread.ThreadPause: Boolean;

begin

FThreadPause := True;

if not Suspended then Suspend;

end;

function TWorkThread.ThreadStop: Boolean;

begin

FThreadPause := False;

FThreadStop := True;

if Suspended then Resume;

end;

procedure TWorkThread.ThreadTerminate;

begin

FThreadStop := False;

if FEvent>0 then

begin

SetEvent(FEvent);

if Suspended then Resume;

end;

end;

procedure TWorkThread._sleep(millisecond: Cardinal);

begin

//WaitForSingleObject(Self.Handle,millisecond);

WaitForSingleObject(FEvent,millisecond);

end;

end.

Main form

unit main;

interface

uses

Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,

Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, unitWorkThread;

type

TfrmMain = class(TForm)

Memo1: TMemo;

btnStart: TButton;

btnPause: TButton;

btnStop: TButton;

Edit1: TEdit;

Edit2: TEdit;

Edit3: TEdit;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure btnStartClick(Sender: TObject);

procedure btnPauseClick(Sender: TObject);

procedure btnStopClick(Sender: TObject);

private

{ Private declarations }

procedure UpdateUI(const value: string);

protected

procedure On_WM_UPDATE_UI(var msg: TMessage);message WM_UPDATE_UI1;

procedure WndProc(var Message: TMessage); override;

public

{ Public declarations }

end;

var

frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.btnPauseClick(Sender: TObject);

begin

WorkThread.ThreadPause;

end;

procedure TfrmMain.btnStartClick(Sender: TObject);

begin

WorkThread.ThreadStart;

end;

procedure TfrmMain.btnStopClick(Sender: TObject);

begin

WorkThread.ThreadStop;

end;

procedure TfrmMain.FormCreate(Sender: TObject);

begin

WorkThread := TWorkThread.Create(True,Memo1);

WorkThread.MainFromHandle := Self.Handle;

WorkThread.DoUpdateUI := UpdateUI;

end;

procedure TfrmMain.FormDestroy(Sender: TObject);

begin

WorkThread.ThreadTerminate;

end;

procedure TfrmMain.On_WM_UPDATE_UI(var msg: TMessage);

begin

Edit1.Text := IntToStr(msg.lParam);

end;

procedure TfrmMain.UpdateUI(const value: string);

begin

Edit1.Text := value;

end;

procedure TfrmMain.WndProc(var Message: TMessage);

begin

case Message.Msg of

WM_UPDATE_UI2:

begin

Edit2.Text := IntToStr(Message.lParam);

end;

WM_UPDATE_UI3:

begin

Edit3.Text := IntToStr(Message.lParam);

end;

else

inherited;

end;

end;

end.

更多信息请查看IT技术专栏