?

在delphi處理線程的時候常常會造成某些未知的bug,搞得程序無法繼續往下走,所以此時我們必需要有應對手策,否則的話,很容易造成我們的工作無法完成

unit Unit1;

interface

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

type
TDemoThread = class(TThread)
private

FOnHintText: TNotifyEvent;

protected
procedure Execute; override;
public
property OnHintText: TNotifyEvent read FOnHintText write FOnHintText;
end;

TForm1 = class(TForm)
Label1: TLabel;
Button2: TButton;
Edit1: TEdit;
Button3: TButton;
Button1: TButton;
Label2: TLabel;
Memo1: TMemo;
Button4: TButton;
procedure ShowThreadDemo(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
Demo: TDemoThread;
function CheckThreadFreed(aThread: TThread): Byte;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

{ TDemoThread }

procedure TDemoThread.Execute;
begin
inherited;
if Assigned(FOnHintText) then
FOnHintText(Self);
end;

procedure TForm1.ShowThreadDemo(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 1000 do
begin
Memo1.Lines.Add(IntToStr(i));
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
vI: DWord;
IsQuit: Boolean;
begin
Demo := TDemoThread.Create(True); //True：創建時不啟動線程
Demo.FreeOnTerminate := True; //設置程結束時自動釋放
Demo.FOnHintText := ShowThreadDemo;
//Demo.OnTerminate:= ShowThreadDemo;
Demo.Resume; //啟劫線程
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
vI: DWord;
IsQuit: Boolean;
begin
if Demo <> nil then
begin
vi := CheckThreadFreed(Demo); //檢查當前線程是否在執行
if (vi = 1) or (vi = 2) then
TerminateThread(Demo.Handle, vi); //如果線程在執行則強行退出
Demo.Free;
end;

{if Demo<> nil then
begin
Demo.Terminate ;
Demo.WaitFor ;
end;} //等待線程結束,并終止它

end;

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

procedure TForm1.Button4Click(Sender: TObject);
var
vI: DWord;
IsQuit: Boolean;
begin
//判斷當前線程的狀態
vI := CheckThreadFreed(Demo);
ShowMessage(IntToStr(vI));
end;

function TForm1.CheckThreadFreed(aThread: TThread): Byte;
var
i: DWord;
IsQuit: Boolean;
begin
if Assigned(aThread) then
begin
IsQuit := GetExitCodeThread(aThread.Handle, i);
if IsQuit then //If the function succeeds, the return value is nonzero.
//If the function fails, the return value is zero.
begin
if i = STILL_ACTIVE then //If the specified thread has not terminated,
//the termination status returned is STILL_ACTIVE.
Result := 1
else
Result := 2; //aThread未Free，因為Tthread.Destroy中有執行語句
end
else
Result := 0; //可以用GetLastError取得錯誤代碼
end
else
Result := 3;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
close;
end;

end

?

轉載于:https://www.cnblogs.com/prtmon/archive/2012/03/29/2423527.html

總結

以上是生活随笔為你收集整理的检测线程是否存活代码！的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。