检测线程是否存活代码！

在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