delphi 多線程編程

開始本應該是一篇洋洋灑灑的文字, 不過我還是提倡先做起來, 在嘗試中去理解.
先試試這個:

procedure TForm1.Button1Click(Sender: TObject); 
var 
i: Integer; 
begin 
for i := 0 to 500000 do 
begin 
Canvas.TextOut(10, 10, IntToStr(i)); 
end; 
end;

上面程序運行時, 我們的窗體基本是 "死" 的, 可以在你在程序運行期間拖動窗體試試...

Delphi 為我們提供了一個簡單的辦法(Application.ProcessMessages)來解決這個問題:

procedure TForm1.Button1Click(Sender: TObject); 
var 
i: Integer; 
begin 
for i := 0 to 500000 do 
begin 
Canvas.TextOut(10, 10, IntToStr(i)); 
Application.ProcessMessages; 
end; 
end;

這個 Application.ProcessMessages; 一般用在比較費時的循環中, 它會檢查並先處理消息隊列中的其他消息.

但這算不上多線程, 譬如: 運行中你拖動窗體, 循環會暫停下來...

在使用多線程以前, 讓我們先簡單修改一下程序:

function MyFun: Integer; 
var 
i: Integer; 
begin 
for i := 0 to 500000 do 
begin 
Form1.Canvas.Lock; 
Form1.Canvas.TextOut(10, 10, IntToStr(i)); 
Form1.Canvas.Unlock; 
end; 
Result := 0; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
MyFun; 
end;

細數上面程序的變化:
1、首先這還不是多線程的, 也會讓窗體假 "死" 一會;
2、把執行代碼寫在了一個函數里, 但這個函數不屬於 TForm1 的方法, 所以使用 Canvas 是必須冠以名稱(Form1);
3、既然是個函數, (不管是否必要)都應該有返回值;
4、使用了 500001 次 Lock 和 Unlock.

Canvas.Lock 好比在說: Canvas(繪圖表面)正忙着呢, 其他想用 Canvas 的等會;
Canvas.Unlock : 用完了, 解鎖!

在 Canvas 中使用 Lock 和 Unlock 是個好習慣, 在不使用多線程的情況下這無所謂, 但保不准哪天程序會擴展為多線程的; 我們現在學習多線程, 當然應該用.

在 Delphi 中使用多線程有兩種方法: 調用 API、使用 TThread 類; 使用 API 的代碼更簡單.

function MyFun(p: Pointer): Integer; stdcall; 
var 
i: Integer; 
begin 
for i := 0 to 500000 do 
begin 
Form1.Canvas.Lock; 
Form1.Canvas.TextOut(10, 10, IntToStr(i)); 
Form1.Canvas.Unlock; 
end; 
Result := 0; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
ID: THandle; 
begin 
CreateThread(nil, 0, @MyFun, nil, 0, ID); 
end;

代碼分析:
CreateThread 一個線程后, 算上原來的主線程, 這樣程序就有兩個線程、是標准的多線程了;
CreateThread 第三個參數是函數指針, 新線程建立后將立即執行該函數, 函數執行完畢, 系統將銷毀此線程從而結束多線程的故事.

CreateThread 要使用的函數是系統級別的, 不能是某個類(譬如: TForm1)的方法, 並且有嚴格的格式(參數、返回值)要求, 不管你暫時是不是需要都必須按格式來;
因為是系統級調用, 還要綴上 stdcall, stdcall 是協調參數順序的, 雖然這里只有一個參數沒有順序可言, 但這是使用系統函數的慣例.

CreateThread 還需要一個 var 參數來接受新建線程的 ID, 盡管暫時沒用, 但這也是格式; 其他參數以后再說吧.

這樣一個最簡單的多線程程序就出來了, 咱們再用 TThread 類實現一次

type 
TMyThread = class(TThread) 
protected 
procedure Execute; override; 
end; 

procedure TMyThread.Execute; 
var 
i: Integer; 
begin 
FreeOnTerminate := True; {這可以讓線程執行完畢后隨即釋放} 
for i := 0 to 500000 do 
begin 
Form1.Canvas.Lock; 
Form1.Canvas.TextOut(10, 10, IntToStr(i)); 
Form1.Canvas.Unlock; 
end; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
TMyThread.Create(False); 
end; 

TThread 類有一個抽象方法(Execute), 因而是個抽象類, 抽象類只能繼承使用, 上面是繼承為 TMyThread.

繼承 TThread 主要就是實現抽象方法 Execute(把我們的代碼寫在里面), 等我們的 TMyThread 實例化后, 首先就會執行 Execute 方法中的代碼.

按常規我們一般這樣去實例化:

procedure TForm1.Button1Click(Sender: TObject); 
var 
MyThread: TMyThread; 
begin 
MyThread := TMyThread.Create(False); 
end; 
因為 MyThread 變量在這里毫無用處(並且編譯器還有提示), 所以不如直接寫做 TMyThread.Create(False);

我們還可以輕松解決一個問題, 如果: TMyThread.Create(True) ?
這樣線程建立后就不會立即調用 Execute, 可以在需要的時候再用 Resume 方法執行線程, 譬如:
procedure TForm1.Button1Click(Sender: TObject); 
var 
MyThread: TMyThread; 
begin 
MyThread := TMyThread.Create(True); 
MyThread.Resume; 
end; 

//可簡化為:

procedure TForm1.Button1Click(Sender: TObject); 
begin 
with TMyThread.Create(True) do Resume; 
end;

一、入門
㈠、
function CreateThread(
lpThreadAttributes: Pointer; {安全設置}
dwStackSize: DWORD; {堆棧大小}
lpStartAddress: TFNThreadStartRoutine; {入口函數}
lpParameter: Pointer; {函數參數}
dwCreationFlags: DWORD; {啟動選項}
var lpThreadId: DWORD {輸出線程 ID }
): THandle; stdcall; {返回線程句柄}

在 Windows 上建立一個線程, 離不開 CreateThread 函數;
TThread.Create 就是先調用了 BeginThread (Delphi 自定義的), BeginThread 又調用的 CreateThread.
既然有建立, 就該有釋放, CreateThread 對應的釋放函數是: ExitThread, 譬如下面代碼:

procedure TForm1.Button1Click(Sender: TObject); 
begin 
ExitThread(0); {此句即可退出當前程序, 但不建議這樣使用} 
end;

代碼注釋:
當前程序是一個進程, 進程只是一個工作環境, 線程是工作者;
每個進程都會有一個啟動線程(或叫主線程), 也就是說: 我們之前大量的編碼都是寫給這個主線程的;
上面的 ExitThread(0); 就是退出這個主線程;
系統不允許一個沒有線程的進程存在, 所以程序就退出了.
另外: ExitThread 函數的參數是一個退出碼, 這個退出碼是給之后的其他函數用的, 這里隨便給個無符號整數即可.

或許你會說: 這個 ExitThread 挺好用的; 其實不管是用 API 還是用 TThread 類寫多線程, 我們很少用到它; 因為:
1、假如直接使用 API 的 CreateThread, 它執行完入口函數后會自動退出, 無需 ExitThread;
2、用 TThread 類建立的線程又絕不能使用 ExitThread 退出; 因為使用 TThread 建立線程時會同時分配更多資源(譬如你自定義的成員、還有它的祖先類(TObject)分配的資源等等), 如果用 ExitThread 給草草退出了, 這些資源將得不到釋放而導致內存泄露. 盡管 Delphi 提供了 EndThread(其內部調用 ExitThread), 這也不需要我們手動操作(假如非要手動操作也是件很麻煩的事情, 因為很多時候你不知道線程是什么時候執行完畢的).
除了 CreateThread, 還有一個 CreateRemoteThread, 可在其他進程中建立線程, 這不應該是現在學習的重點;
現在先集中精力把 CreateThread 的參數搞徹底.

倒着來吧, 先談談 CreateThread 將要返回的 "線程句柄".

"句柄" 類似指針, 但通過指針可讀寫對象, 通過句柄只是使用對象;
有句柄的對象一般都是系統級別的對象(或叫內核對象); 之所以給我們的是句柄而不是指針, 目的只有一個: "安全";
貌似通過句柄能做很多事情, 但一般把句柄提交到某個函數(一般是系統函數)后, 我們也就到此為止很難了解更多了; 事實上是系統並不相信我們.

不管是指針還是句柄, 都不過是內存中的一小塊數據(一般用結構描述), 微軟並沒有公開句柄的結構細節, 猜一下它應該包括: 真實的指針地址、訪問權限設置、引用計數等等.

既然 CreateThread 可以返回一個句柄, 說明線程屬於 "內核對象".
實際上不管線程屬於哪個進程, 它們在系統的懷抱中是平等的; 在優先級(后面詳談)相同的情況下, 系統會在相同的時間間隔內來運行一下每個線程, 不過這個間隔很小很小, 以至於讓我們誤以為程序是在不間斷地運行.

這時你應該有一個疑問: 系統在去執行其他線程的時候, 是怎么記住前一個線程的數據狀態的?
有這樣一個結構 TContext, 它基本上是一個 CPU 寄存器的集合, 線程是數據就是通過這個結構切換的, 我們也可以通過 GetThreadContext 函數讀取寄存器看看.

附上這個結構 TContext(或叫: CONTEXT、_CONTEXT) 的定義:

PContext = ^TContext; 
_CONTEXT = record 
ContextFlags: DWORD; 
Dr0: DWORD; 
Dr1: DWORD; 
Dr2: DWORD; 
Dr3: DWORD; 
Dr6: DWORD; 
Dr7: DWORD; 
FloatSave: TFloatingSaveArea; 
SegGs: DWORD; 
SegFs: DWORD; 
SegEs: DWORD; 
SegDs: DWORD; 
Edi: DWORD; 
Esi: DWORD; 
Ebx: DWORD; 
Edx: DWORD; 
Ecx: DWORD; 
Eax: DWORD; 
Ebp: DWORD; 
Eip: DWORD; 
SegCs: DWORD; 
EFlags: DWORD; 
Esp: DWORD; 
SegSs: DWORD; 
end;

CreateThread 的最后一個參數是 "線程的 ID";
既然可以返回句柄, 為什么還要輸出這個 ID? 現在我知道的是:
1、線程的 ID 是唯一的; 而句柄可能不只一個, 譬如可以用 GetCurrentThread 獲取一個偽句柄、可以用 DuplicateHandle 復制一個句柄等等.
2、ID 比句柄更輕便.

在主線程中 GetCurrentThreadId、MainThreadID、MainInstance 獲取的都是主線程的 ID.
㈡、啟動選項
function CreateThread(
lpThreadAttributes: Pointer;
dwStackSize: DWORD;
lpStartAddress: TFNThreadStartRoutine;
lpParameter: Pointer;
dwCreationFlags: DWORD; {啟動選項}
var lpThreadId: DWORD
): THandle; stdcall;
CreateThread 的倒數第二個參數 dwCreationFlags(啟動選項) 有兩個可選值:
0: 線程建立后立即執行入口函數;
CREATE_SUSPENDED: 線程建立后會掛起等待.

可用 ResumeThread 函數是恢復線程的運行; 可用 SuspendThread 再次掛起線程.
這兩個函數的參數都是線程句柄, 返回值是執行前的掛起計數.

什么是掛起計數?
SuspendThread 會給這個數 +1; ResumeThread 會給這個數 -1; 但這個數最小是 0.
當這個數 = 0 時, 線程會運行; > 0 時會掛起.
如果被 SuspendThread 多次, 同樣需要 ResumeThread 多次才能恢復線程的運行.

在下面的例子中, 有新線程不斷給一個全局變量賦隨機值;
同時窗體上的 Timer 控件每隔 1/10 秒就把這個變量寫在窗體標題;
在這個過程中演示了 ResumeThread、SuspendThread 兩個函數.

//上面圖片中演示的代碼。

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls, ExtCtrls; 

type 
TForm1 = class(TForm) 
Button1: TButton; 
Button2: TButton; 
Button3: TButton; 
Timer1: TTimer; 
procedure Button1Click(Sender: TObject); 
procedure Button2Click(Sender: TObject); 
procedure Button3Click(Sender: TObject); 
procedure FormCreate(Sender: TObject); 
procedure Timer1Timer(Sender: TObject); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

var 
hThread: THandle; {線程句柄} 
num: Integer; {全局變量, 用於記錄隨機數} 

{線程入口函數} 
function MyThreadFun(p: Pointer): Integer; stdcall; 
begin 
while True do {假如線程不掛起, 這個循環將一直循環下去} 
begin 
num := Random(100); 
end; 
Result := 0; 
end; 

{建立並掛起線程} 
procedure TForm1.Button1Click(Sender: TObject); 
var 
ID: DWORD; 
begin 
hThread := CreateThread(nil, 0, @MyThreadFun, nil, CREATE_SUSPENDED, ID); 
Button1.Enabled := False; 
end; 

{喚醒並繼續線程} 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
ResumeThread(hThread); 
end; 

{掛起線程} 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
SuspendThread(hThread); 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
Timer1.Interval := 100; 
end; 

procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
Text := IntToStr(num); 
end; 

end.

㈢、入口函數的參數
function CreateThread(
lpThreadAttributes: Pointer;
dwStackSize: DWORD;
lpStartAddress: TFNThreadStartRoutine;
lpParameter: Pointer; {入口函數的參數}
dwCreationFlags: DWORD;
var lpThreadId: DWORD
): THandle; stdcall;
線程入口函數的參數是個無類型指針(Pointer), 用它可以指定任何數據; 本例是把鼠標點擊窗體的坐標傳遞給線程的入口函數, 每次點擊窗體都會創建一個線程.

運行效果圖:

//上面演示的代碼 
unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs; 

type 
TForm1 = class(TForm) 
procedure FormMouseUp(Sender: TObject; Button: TMouseButton; 
Shift: TShiftState; X, Y: Integer); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

var 
pt: TPoint; {這個坐標點將會已指針的方式傳遞給線程, 它應該是全局的} 

function MyThreadFun(p: Pointer): Integer; stdcall; 
var 
i: Integer; 
pt2: TPoint; {因為指針參數給的點隨時都在變, 需用線程的局部變量存起來} 
begin 
pt2 := PPoint(p)^; {轉換} 
for i := 0 to 1000000 do 
begin 
with Form1.Canvas do begin 
Lock; 
TextOut(pt2.X, pt2.Y, IntToStr(i)); 
Unlock; 
end; 
end; 
Result := 0; 
end; 

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; 
Shift: TShiftState; X, Y: Integer); 
var 
ID: DWORD; 
begin 
pt := Point(X, Y); 
CreateThread(nil, 0, @MyThreadFun, @pt, 0, ID); 
{下面這種寫法更好理解, 其實不必, 因為 PPoint 會自動轉換為 Pointer 的} 
//CreateThread(nil, 0, @MyThreadFun, Pointer(@pt), 0, ID); 
end; 

end.

 

這個例子還有不嚴謹的地方: 當一個線程 Lock 窗體的 Canvas 時, 其他線程在等待; 線程在等待時, 其中的計數也還在增加. 這也就是說: 現在並沒有去處理線程的同步; 同步是多線程中最重要的課題, 快到了.

另外有個小技巧: 線程函數的參數是個 32 位(4個字節)的指針, 僅就本例來講, 可以讓它的 "高16位" 和 "低16位" 分別攜帶 X 和 Y; 這樣就不需要哪個全局的 pt 變量了.
其實在 Windows 的消息中就是這樣傳遞坐標的, 在 Windows 的消息中一般高字節是 Y、低字節是 X; 咱們這么來吧, 這樣還可以使用給消息准備的一些方便的函數.

重寫本例代碼(當然運行效果和窗體文件都是一樣的):

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs; 

type 
TForm1 = class(TForm) 
procedure FormMouseUp(Sender: TObject; Button: TMouseButton; 
Shift: TShiftState; X, Y: Integer); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

function MyThreadFun(p: Pointer): Integer; stdcall; 
var 
i: Integer; 
x,y: Word; 
begin 
x := LoWord(Integer(p)); 
y := HiWord(Integer(p)); 
{如果不使用 LoWord、HiWord 函數可以像下面這樣: } 
//x := Integer(p); 
//y := Integer(p) shr 16; 
for i := 0 to 1000000 do 
begin 
with Form1.Canvas do begin 
Lock; 
TextOut(x, y, IntToStr(i)); 
Unlock; 
end; 
end; 
Result := 0; 
end; 

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; 
Shift: TShiftState; X, Y: Integer); 
var 
ID: DWORD; 
num: Integer; 
begin 
num := MakeLong(X, Y); 
{如果不使用 MekeLong、MakeWParam、MakeLParam、MakeResult 等函數, 可以像下面這樣: } 
//num := Y shl 16 + X; 
CreateThread(nil, 0, @MyThreadFun, Ptr(num), 0, ID); 
{上面的 Ptr 是專門將一個數字轉換為指針的函數, 當然也可以這樣: } 
//CreateThread(nil, 0, @MyThreadFun, Pointer(num), 0, ID); 
end; 

end.

㈣、入口函數的指針
function CreateThread(
lpThreadAttributes: Pointer;
dwStackSize: DWORD;
lpStartAddress: TFNThreadStartRoutine; {入口函數的指針}
lpParameter: Pointer;
dwCreationFlags: DWORD;
var lpThreadId: DWORD
): THandle; stdcall;

到了入口函數了, 學到這個地方, 我查了一個入口函數的標准定義, 這個函數的標准返回值應該是 DWORD, 不過這函數在 Delphi 的 System 單元定義的是: TThreadFunc = function(Parameter: Pointer): Integer; 我以后會盡量使用 DWORD 做入口函數的返回值.

這個返回值有什么用呢?
等線程退出后, 我們用 GetExitCodeThread 函數獲取的退出碼就是這個返回值!

如果線程沒有退出, GetExitCodeThread 獲取的退出碼將是一個常量 STILL_ACTIVE (259); 這樣我們就可以通過退出碼來判斷線程是否已退出.

還有一個問題: 前面也提到過, 線程函數不能是某個類的方法! 假如我們非要線程去執行類中的一個方法能否實現呢?
盡管可以用 Addr(類名.方法名) 或 MethodAddress('published 區的方法名') 獲取類中方法的地址, 但都不能當做線程的入口函數, 原因可能是因為類中的方法的地址是在實例化為對象時動態分配的.
后來換了個思路, 其實很簡單: 在線程函數中再調用方法不就得了, 估計 TThread 也應該是這樣.

下面的例子就嘗試了用線程調用 TForm1 類中的方法, 並測試了退出碼的相關問題.

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls; 

type 
TForm1 = class(TForm) 
Button1: TButton; 
Button2: TButton; 
procedure Button1Click(Sender: TObject); 
procedure Button2Click(Sender: TObject); 
private 
procedure FormProc; {准備給線程使用的方法} 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

var 
hThread: THandle; 

{線程入口函數} 
function MyThreadFun(p: Pointer): DWORD; stdcall; 
begin 
Form1.FormProc; {調用 TForm1 類的方法} 
Result := 99; {這個返回值將成為線程的退出代碼, 99 是我隨意給的數字} 
end; 

{TForm1 的方法, 本例中是給線程的入口函數調用的} 
procedure TForm1.FormProc; 
var 
i: Integer; 
begin 
for i := 0 to 200000 do 
begin 
with Form1.Canvas do begin 
Lock; 
TextOut(10, 10, IntToStr(i)); 
Unlock; 
end; 
end; 
end; 

{建立並執行線程} 
procedure TForm1.Button1Click(Sender: TObject); 
var 
ID: DWORD; 
begin 
hThread := CreateThread(nil, 0, @MyThreadFun, nil, 0, ID); 
end; 

{獲取線程的退出代碼, 並判斷線程是否退出} 
procedure TForm1.Button2Click(Sender: TObject); 
var 
ExitCode: DWORD; 
begin 
GetExitCodeThread(hThread, ExitCode); 

if hThread = 0 then 
begin 
Text := '線程還未啟動'; 
Exit; 
end; 

if ExitCode = STILL_ACTIVE then 
Text := Format('線程退出代碼是: %d, 表示線程還未退出', [ExitCode]) 
else 
Text := Format('線程已退出, 退出代碼是: %d', [ExitCode]); 
end; 

end.

㈤、堆棧大小
function CreateThread(
lpThreadAttributes: Pointer;
dwStackSize: DWORD; {堆棧大小}
lpStartAddress: TFNThreadStartRoutine;
lpParameter: Pointer;
dwCreationFlags: DWORD;
var lpThreadId: DWORD
): THandle; stdcall;

CreateThread 的第二個參數是分配給線程的堆棧大小.
這首先這可以讓我們知道: 每個線程都有自己獨立的堆棧(也擁有自己的消息隊列).

什么是堆棧? 其實堆是堆、棧是棧, 有時 "棧" 也被叫做 "堆棧".
它們都是進程中的內存區域, 主要是存取方式不同(棧:先進后出; 堆:先進先出);
"棧"(或叫堆棧)適合存取臨時而輕便的變量, 主要用來儲存局部變量; 譬如 for i := 0 to 99 do 中的 i 就只能存於棧中, 你把一個全局的變量用於 for 循環計數是不可以的.

現在我們知道了線程有自己的 "棧", 並且在建立線程時可以分配棧的大小.

前面所有的例子中, 這個值都是 0, 這表示使用系統默認的大小, 默認和主線程棧的大小一樣, 如果不夠用會自動增長;
那主線程的棧有多大? 這個值是可以設定的: Project -> Options -> linker -> memory size(如圖)

棧是私有的但堆是公用的, 如果不同的線程都來使用一個全局變量有點亂套;
為解決這個問題 Delphi 為我們提供了一個類似 var 的 ThreadVar 關鍵字, 線程在使用 ThreadVar 聲明的全局變量時會在各自的棧中留一個副本, 這樣就解決了沖突. 不過還是盡量使用局部變量, 或者在繼承 TThread 時使用類的成員變量, 因為 ThreadVar 的效率不好, 據說比局部變量能慢 10 倍.

在下面的例子就測試了用 var 和 ThreadVar 定義變量的不同.

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls; 

type 
TForm1 = class(TForm) 
Button1: TButton; 
procedure Button1Click(Sender: TObject); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

//var num: Integer; {全局變量} 
threadvar num: Integer; {支持多線程的全局變量} 

function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
py: Integer; 
begin 
py := Integer(p); 
while True do 
begin 
Inc(num); 
with Form1.Canvas do begin 
Lock; 
TextOut(20, py, IntToStr(num)); 
Unlock; 
end; 
Sleep(1000); {然線程掛起 1 秒鍾再繼續} 
end; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
ID: DWORD; 
begin 
{借入口函數的參數傳遞了一個坐標點中的 Y 值, 以讓各線程把結果輸出在不同位置} 
CreateThread(nil, 0, @MyThreadFun, Ptr(20), 0, ID); 
CreateThread(nil, 0, @MyThreadFun, Ptr(40), 0, ID); 
CreateThread(nil, 0, @MyThreadFun, Ptr(60), 0, ID); 
end; 

end.

㈥、安全設置

function CreateThread( 
lpThreadAttributes: Pointer; {安全設置} 
dwStackSize: DWORD; 
lpStartAddress: TFNThreadStartRoutine; 
lpParameter: Pointer; 
dwCreationFlags: DWORD; 
var lpThreadId: DWORD 
): THandle; stdcall;
CreateThread 的第一個參數 lpThreadAttributes 是指向 TSecurityAttributes 結構的指針, 一般都是置為 nil, 這表示沒有訪問限制; 該結構的定義是:
//TSecurityAttributes(又名: SECURITY_ATTRIBUTES、_SECURITY_ATTRIBUTES) 
_SECURITY_ATTRIBUTES = record 
nLength: DWORD; {結構大小} 
lpSecurityDescriptor: Pointer; {默認 nil; 這是另一個結構 TSecurityDescriptor 的指針} 
bInheritHandle: BOOL; {默認 False, 表示不可繼承} 
end; 

//TSecurityDescriptor(又名: SECURITY_DESCRIPTOR、_SECURITY_DESCRIPTOR) 
_SECURITY_DESCRIPTOR = record 
Revision: Byte; 
Sbz1: Byte; 
Control: SECURITY_DESCRIPTOR_CONTROL; 
Owner: PSID; 
Group: PSID; 
Sacl: PACL; 
Dacl: PACL; 
end;

夠復雜的, 但我們在多線程編程時不需要去設置它們, 大都是使用默認設置(也就是賦值為 nil).

我覺得有必要在此刻了解的是: 建立系統內核對象時一般都有這個屬性(TSecurityAttributes);
在接下來多線程的課題中要使用一些內核對象, 不如先盤點一下, 到時碰到這個屬性時給個 nil 即可, 不必再費神.

{建立事件} 
function CreateEvent( 
lpEventAttributes: PSecurityAttributes; {!} 
bManualReset: BOOL; 
bInitialState: BOOL; 
lpName: PWideChar 
): THandle; stdcall; 

{建立互斥} 
function CreateMutex( 
lpMutexAttributes: PSecurityAttributes; {!} 
bInitialOwner: BOOL; 
lpName: PWideChar 
): THandle; stdcall; 

{建立信號} 
function CreateSemaphore( 
lpSemaphoreAttributes: PSecurityAttributes; {!} 
lInitialCount: Longint; 
lMaximumCount: Longint; 
lpName: PWideChar 
): THandle; stdcall; 

{建立等待計時器} 
function CreateWaitableTimer( 
lpTimerAttributes: PSecurityAttributes; {!} 
bManualReset: BOOL; 
lpTimerName: PWideChar 
): THandle; stdcall; 

上面的四個系統內核對象(事件、互斥、信號、計時器)都是線程同步的手段, 從這也能看出處理線程同步的復雜性; 不過這還不是全部, Windows Vista 開始又增加了 Condition variables(條件變量)、Slim Reader-Writer Locks(讀寫鎖)等同步手段.

不過最簡單、最輕便(速度最快)的同步手段還是 CriticalSection(臨界區), 但它不屬於系統內核對象, 當然也就沒有句柄、沒有 TSecurityAttributes 這個安全屬性, 這也導致它不能跨進程使用; 不過寫多線程時一般不用跨進程, 所以 CriticalSection 應該是最常用的同步手段.

二、臨界區。
先看一段程序, 代碼文件:

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls; 

type 
TForm1 = class(TForm) 
ListBox1: TListBox; 
Button1: TButton; 
procedure FormCreate(Sender: TObject); 
procedure Button1Click(Sender: TObject); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
i: Integer; 
begin 
for i := 0 to 99 do Form1.ListBox1.Items.Add(IntToStr(i)); 
Result := 0; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
ID: DWORD; 
begin 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ID); 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
ListBox1.Align := alLeft; 
end; 

end.

在這段程序中, 有三個線程幾乎是同時建立, 向窗體中的 ListBox1 中寫數據, 最后寫出的結果是這樣的:

能不能讓它們別打架, 一個完了另一個再來? 這就要用到多線程的同步技術.
前面說過, 最簡單的同步手段就是 "臨界區".

先說這個 "同步"(Synchronize), 首先這個名字起的不好, 我們好像需要的是 "異步"; 其實異步也不准確...
管它叫什么名字呢, 它的目的就是保證不沖突、有次序、都發生.

"臨界區"(CriticalSection): 當把一段代碼放入一個臨界區, 線程執行到臨界區時就獨占了, 讓其他也要執行此代碼的線程先等等; 這和前面用的 Lock 和 UnLock 差不多; 使用格式如下:
var CS: TRTLCriticalSection; {聲明一個 TRTLCriticalSection 結構類型變量; 它應該是全局的}
InitializeCriticalSection(CS); {初始化}
EnterCriticalSection(CS); {開始: 輪到我了其他線程走開}
LeaveCriticalSection(CS); {結束: 其他線程可以來了}
DeleteCriticalSection(CS); {刪除: 注意不能過早刪除}

//也可用 TryEnterCriticalSection 替代 EnterCriticalSection.
用上臨界區, 重寫上面的代碼, 運行效果圖:

//用臨界區重寫后的代碼文件: 
unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls; 

type 
TForm1 = class(TForm) 
ListBox1: TListBox; 
Button1: TButton; 
procedure FormCreate(Sender: TObject); 
procedure FormDestroy(Sender: TObject); 
procedure Button1Click(Sender: TObject); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

var 
CS: TRTLCriticalSection; 

function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
i: Integer; 
begin 
EnterCriticalSection(CS); 
for i := 0 to 99 do Form1.ListBox1.Items.Add(IntToStr(i)); 
LeaveCriticalSection(CS); 
Result := 0; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
ID: DWORD; 
begin 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ID); 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
ListBox1.Align := alLeft; 
InitializeCriticalSection(CS); 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
DeleteCriticalSection(CS); 
end; 

end.

Delphi 在 SyncObjs 單元給封裝了一個 TCriticalSection 類, 用法差不多, 代碼如下:

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls; 

type 
TForm1 = class(TForm) 
ListBox1: TListBox; 
Button1: TButton; 
procedure FormCreate(Sender: TObject); 
procedure FormDestroy(Sender: TObject); 
procedure Button1Click(Sender: TObject); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

uses SyncObjs; 

var 
CS: TCriticalSection; 

function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
i: Integer; 
begin 
CS.Enter; 
for i := 0 to 99 do Form1.ListBox1.Items.Add(IntToStr(i)); 
CS.Leave; 
Result := 0; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
ID: DWORD; 
begin 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ID); 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
ListBox1.Align := alLeft; 
CS := TCriticalSection.Create; 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
CS.Free; 
end; 

end.

三、等待函數 WaitForSingleObject
一下子跳到等待函數 WaitForSingleObject, 是因為下面的 Mutex、Semaphore、Event、WaitableTimer 等同步手段都要使用這個函數; 不過等待函數可不止 WaitForSingleObject 它一個, 但它最簡單.
function WaitForSingleObject(
hHandle: THandle; {要等待的對象句柄}
dwMilliseconds: DWORD {等待的時間, 單位是毫秒}
): DWORD; stdcall; {返回值如下:}
WAIT_OBJECT_0 {等着了, 本例中是: 等的那個進程終於結束了}
WAIT_TIMEOUT {等過了點(你指定的時間), 也沒等着}
WAIT_ABANDONED {好不容易等着了, 但人家還是不讓咱執行; 這一般是互斥對象}
//WaitForSingleObject 的第二個參數一般給常數值 INFINITE, 表示一直等下去, 死等.

WaitForSingleObject 等待什么? 在多線程里就是等待另一個線程的結束, 快來執行自己的代碼; 不過它可以等待的對象可不止線程; 這里先來一個等待另一個進程結束的例子, 運行效果圖:
//WaitForSingleObject的示例代碼文件:

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls; 

type 
TForm1 = class(TForm) 
Button1: TButton; 
procedure Button1Click(Sender: TObject); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

var 
hProcess: THandle; {進程句柄} 

{等待一個指定句柄的進程什么時候結束} 
function MyThreadFun(p: Pointer): DWORD; stdcall; 
begin 
if WaitForSingleObject(hProcess, INFINITE) = WAIT_OBJECT_0 then 
Form1.Text := Format('進程 %d 已關閉', [hProcess]); 
Result := 0; 
end; 

{啟動一個進程, 並建立新線程等待它的結束} 
procedure TForm1.Button1Click(Sender: TObject); 
var 
pInfo: TProcessInformation; 
sInfo: TStartupInfo; 
Path: array[0..MAX_PATH-1] of Char; 
ThreadID: DWORD; 
begin 
{先獲取記事本的路徑} 
GetSystemDirectory(Path, MAX_PATH); 
StrCat(Path, '\notepad.exe'); 

{用 CreateProcess 打開記事本並獲取其進程句柄, 然后建立線程監視} 
FillChar(sInfo, SizeOf(sInfo), 0); 
if CreateProcess(Path, nil, nil, nil, False, 0, nil, nil, sInfo, pInfo) then 
begin 
hProcess := pInfo.hProcess; {獲取進程句柄} 
Text := Format('進程 %d 已啟動', [hProcess]); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); {建立線程監視} 
end; 
end; 

end.

四、多線程同步之 Mutex (互斥對象)
原理分析:
互斥對象是系統內核對象, 各線程都可以擁有它, 誰擁有誰就能執行;
執行完畢, 用 ReleaseMutex 函數釋放擁有權, 以讓其他等待的線程使用.
其他線程可用 WaitForSingleObject 函數排隊等候(等候也可以理解為排隊申請).

使用過程:

var hMutex: THandle; {應該先聲明一個全局的互斥句柄}
CreateMutex {建立一個互斥對象}
WaitForSingleObject {用等待函數排隊等候}
ReleaseMutex {釋放擁有權}
CloseHandle {最后釋放互斥對象}


ReleaseMutex、CloseHandle 的參數都是 CreateMutex 返回的句柄, 關鍵是 CreateMutex 函數:

function CreateMutex(
lpMutexAttributes: PSecurityAttributes;
bInitialOwner: BOOL; {是否讓創建者(此例中是主線程)擁有該互斥對象}
lpName: PWideChar {可以給此互斥對象取個名字, 如果不要名字可賦值為 nil}
): THandle;
{
1、第一個參數前面說過.
2、第二個參數在這里一定要是 False, 如果讓主線程擁有互斥, 從理論上講, 得等程序退出后其他線程才有機會;
取值 False 時, 第一個執行的線程將會最先擁有互斥對象, 一旦擁有其他線程就得先等等.
3、第三個參數, 如果給個名字, 函數將從系統中尋找是否有重名的互斥對象, 如果有則返回同名對象的存在的句柄;
如果賦值為 nil 將直接創建一個新的互斥對象; 下個例子將會有名字. }

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls; 

type 
TForm1 = class(TForm) 
Button1: TButton; 
procedure Button1Click(Sender: TObject); 
procedure FormCreate(Sender: TObject); 
procedure FormDestroy(Sender: TObject); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

var 
f: Integer; {用這個變量協調一下各線程輸出的位置} 
hMutex: THandle; {互斥對象的句柄} 

function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
i,y: Integer; 
begin 
Inc(f); 
y := 20 * f; 
for i := 0 to 50000 do 
begin 
if WaitForSingleObject(hMutex, INFINITE) = WAIT_OBJECT_0 then 
begin 
Form1.Canvas.Lock; 
Form1.Canvas.TextOut(20, y, IntToStr(i)); 
Form1.Canvas.Unlock; 
Sleep(0); {稍稍耽擱一點, 不然有時 Canvas 會協調不過來} 
ReleaseMutex(hMutex); 
end; 
end; 
Result := 0; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
ThreadID: DWORD; 
begin 
Repaint; 
f := 0; 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
hMutex := CreateMutex(nil, False, nil); 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
CloseHandle(hMutex); 
end; 

end.

SyncObjs 單元下有封裝好的 TMutex 類, 好像不如 Api 快, 內部機制也稍有區別, 但使用方法差不多:

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls; 

type 
TForm1 = class(TForm) 
Button1: TButton; 
procedure Button1Click(Sender: TObject); 
procedure FormCreate(Sender: TObject); 
procedure FormDestroy(Sender: TObject); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

uses SyncObjs; 
var 
f: Integer; 
MyMutex: TMutex; 

function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
i,y: Integer; 
begin 
Inc(f); 
y := 20 * f; 
for i := 0 to 50000 do 
begin 
if MyMutex.WaitFor(INFINITE) = wrSignaled then 
begin 
Form1.Canvas.Lock; 
Form1.Canvas.TextOut(20, y, IntToStr(i)); 
Form1.Canvas.Unlock; 
MyMutex.Release; 
end; 
end; 
Result := 0; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
ThreadID: DWORD; 
begin 
Repaint; 
f := 0; 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
MyMutex := TMutex.Create(False); 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
MyMutex.Free; 
end; 

end.

Mutex 作為系統核心對象是可以跨進程的(臨界區就不行), 我們可以利用互斥對象禁止程序重復啟動.

工作思路:
先用 OpenMutex 嘗試打開一個自定義名稱的 Mutex 對象, 如果打開失敗說明之前沒有這個對象存在;
如果之前沒有這個對象, 馬上用 CreateMutex 建立一個, 此時的程序應該是第一次啟動;
再重復啟動時, 那個 OpenMutex 就有結果了, 然后強制退出.
最后在程序結束時用 CloseHandle 釋放 Mutex 對象.

function OpenMutex(
dwDesiredAccess: DWORD; {打開權限}
bInheritHandle: BOOL; {能否被當前程序創建的進程繼承}
pName: PWideChar {Mutex 對象的名稱}
): THandle; stdcall; {成功返回 Mutex 的句柄; 失敗返回 0}

注意, 這里的 CreateMutex 函數應該有個名了, 因為 OpenMutex 要用到;
另外, CreateMutex 的第二個參數已經不重要了(也就是 True 和 False 都行), 因為這里是用其名稱來判斷的.

程序可以這樣寫:

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs; 

type 
TForm1 = class(TForm) 
procedure FormCreate(Sender: TObject); 
procedure FormDestroy(Sender: TObject); 
end; 

var 
Form1: TForm1; 

implementation 

{$R *.dfm} 

var 
hMutex: THandle; 
const 
NameMutex = 'MyMutex'; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
if OpenMutex(MUTEX_ALL_ACCESS, False, NameMutex) <> 0 then 
begin 
ShowMessage('該程序已啟動'); 
Application.Terminate; 
end; 
hMutex := CreateMutex(nil, False, NameMutex); 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
CloseHandle(hMutex); 
end; 

end.

這一般都是寫在 dpr 主程序里, 省得讓后啟動的程序執行些無用的代碼:

program Project1; 

uses 
Forms, Windows, 
Unit1 in 'Unit1.pas' {Form1}; 

{$R *.res} 

var 
hMutex: THandle; 
const 
NameMutex = 'MyMutex'; 

begin 
{主線程入口} 
if OpenMutex(MUTEX_ALL_ACCESS, False, NameMutex) <> 0 then 
begin 
MessageBox(0, '該程序已啟動', '提示', MB_OK); 
Application.Terminate; 
end; 
hMutex := CreateMutex(nil, False, NameMutex); 

Application.Initialize; 
Application.MainFormOnTaskbar := True; 
Application.CreateForm(TForm1, Form1); 
Application.Run; 

CloseHandle(hMutex); 
{主線程出口} 
end. 

五、多線程同步之 Semaphore (信號對象)
之前已經有了兩種多線程的同步方法:
CriticalSection(臨界區) 和 Mutex(互斥), 這兩種同步方法差不多, 只是作用域不同;
CriticalSection(臨界區) 類似於只有一個蹲位的公共廁所, 只能一個個地進;
Mutex(互斥) 對象類似於接力賽中的接力棒, 某一時刻只能一個人持有, 誰拿着誰跑.

什么是 Semaphore(信號或叫信號量)呢?
譬如到銀行辦業務、或者到車站買票, 原來只有一個服務員, 不管有多少人排隊等候, 業務只能一個個地來.
假如增加了業務窗口, 可以同時受理幾個業務呢?
這就類似與 Semaphore 對象, Semaphore 可以同時處理等待函數(如: WaitForSingleObject)申請的幾個線程.

Semaphore 的工作思路如下:
1、首先要通過 CreateSemaphore(安全設置, 初始信號數, 信號總數, 信號名稱) 建立信號對象;
參數四: 和 Mutex 一樣, 它可以有個名稱, 也可以沒有, 本例就沒有要名稱(nil); 有名稱的一般用於跨進程.
參數三: 信號總數, 是 Semaphore 最大處理能力, 就像銀行一共有多少個業務窗口一樣;
參數二: 初始信號數, 這就像銀行的業務窗口很多, 但打開了幾個可不一定, 如果沒打開和沒有一樣;
參數一: 安全設置和前面一樣, 使用默認(nil)即可.

2、要接受 Semaphore 服務(或叫協調)的線程, 同樣需要用等待函數(如: WaitForSingleObject)排隊等候;

3、當一個線程使用完一個信號, 應該用 ReleaseSemaphore(信號句柄, 1, nil) 讓出可用信號給其他線程;
參數三: 一般是 nil, 如果給個數字指針, 可以接受到此時(之前)總共閑置多少個信號;
參數二: 一般是 1, 表示增加一個可用信號;
如果要增加 CreateSemaphore 時的初始信號, 也可以通過 ReleaseSemaphore.

4、最后, 作為系統內核對象, 要用 CloseHandle 關閉.

另外, 在 Semaphore 的總數是 1 的情況下, 就和 Mutex(互斥) 一樣了.

在本例中, 每點擊按鈕, 將建立一個信號總數為 5 的信號對象, 初始信號來自 Edit1; 同時有 5 個線程去排隊.
本例也附上了 Delphi 中 TSemaphore 類的例子, 但沒有過多地糾纏於細節, 是為了盡快理出多線程的整體思路.

unit Unit1; 
interface 
uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls; 
type 
TForm1 = class(TForm) 
Button1: TButton; 
Edit1: TEdit; 
procedure Button1Click(Sender: TObject); 
procedure FormCreate(Sender: TObject); 
procedure FormDestroy(Sender: TObject); 
end; 
var 
Form1: TForm1; 
implementation 
{$R *.dfm} 
var 
f: Integer; {用這個變量協調一下各線程輸出的位置} 
hSemaphore: THandle; {信號對象的句柄} 
function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
i,y: Integer; 
begin 
Inc(f); 
y := 20 * f; 
if WaitForSingleObject(hSemaphore, INFINITE) = WAIT_OBJECT_0 then 
begin 
for i := 0 to 100 do 
begin 
Form1.Canvas.Lock; 
Form1.Canvas.TextOut(20, y, IntToStr(i)); 
Form1.Canvas.Unlock; 
Sleep(1); {以免 Canvas 忙不過來} 
end; 
end; 
ReleaseSemaphore(hSemaphore, 1, nil); 
Result := 0; 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
var 
ThreadID: DWORD; 
begin 
{不知是不是之前創建過 Semaphore 對象, 假如有先關閉} 
CloseHandle(hSemaphore); 
{創建 Semaphore 對象} 
hSemaphore := CreateSemaphore(nil, StrToInt(Edit1.Text), 5, nil); 
Self.Repaint; 
f := 0; 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
end; 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
Edit1.Text := '1'; 
end; 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
CloseHandle(hSemaphore); 
end; 
end.

再用 SyncObjs 單元下的 TSemaphore 類實現一次, 使用方法差不多, 運行效果也一樣:

unit Unit1; 
interface 
uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs, StdCtrls; 
type 
TForm1 = class(TForm) 
Button1: TButton; 
Edit1: TEdit; 
procedure Button1Click(Sender: TObject); 
procedure FormCreate(Sender: TObject); 
procedure FormDestroy(Sender: TObject); 
procedure Edit1KeyPress(Sender: TObject; var Key: Char); 
end; 
var 
Form1: TForm1; 
implementation 
{$R *.dfm} 
uses SyncObjs; 
var 
f: Integer; 
MySemaphore: TSemaphore; 
function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
i,y: Integer; 
begin 
Inc(f); 
y := 20 * f; 
if MySemaphore.WaitFor(INFINITE) = wrSignaled then 
begin 
for i := 0 to 1000 do 
begin 
Form1.Canvas.Lock; 
Form1.Canvas.TextOut(20, y, IntToStr(i)); 
Form1.Canvas.Unlock; 
Sleep(1); 
end; 
end; 
MySemaphore.Release; 
Result := 0; 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
var 
ThreadID: DWORD; 
begin 
if Assigned(MySemaphore) then MySemaphore.Free; 
MySemaphore := TSemaphore.Create(nil, StrToInt(Edit1.Text), 5, ''); 
Self.Repaint; 
f := 0; 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
CreateThread(nil, 0, @MyThreadFun, nil, 0, ThreadID); 
end; 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
Edit1.Text := '1'; 
end; 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
if Assigned(MySemaphore) then MySemaphore.Free; 
end; 
end.