dkopg24406

delphi 多线程3

多线程程序设计

　我们知道，win95或winNT都是“多线程”的操作系统，在DELPHI 2．0中，我们可以充分利用这一特性，编写出“多线程”的应用程序。 
　　对以往在DOS或16位windows下写程序的人来说，“多线程”仍然是陌生的，但如同以前我们从DOS下的单任务过渡到windows3．1下的多任务，如今我们又必须过渡到“多线程”领域，毕竟计算机时代是在不断发展的。不过，幸运的是，在DELPHI2．0下进行多线程程序设计并不需要我们去学习庞大的WIN32API函数，我们可以利用DELPHI下标准的多线程类TThread来完成我们的工作。 
　　TThread是一个abstract（抽象）类，也就是说，并不需要根据TThread来声明变量（而且根据TThread声明的变量也是完全无用），我们要做的是把TThread作为基类，用继承的形式来生成子类。实际上，根据TThread来写多线程应用程序是非常容易的。 
　　下面就是一个基本的继承TThread生成的多线程类。 
　　QuerThrd．Pas 
　　unitQuerThrd； 
　　interface 
　　uses 
　　Classes，DBTables； 
　　type 
　　TQueryThreadΚclass（TThread） 
　　private 
　　fQuery：tQuery； 
　　protected 
　　procedureExecute；override； 
　　public 
　　constructorCreate（Suspended：Boolean；Query：TQuery）； 
　　end； 
　　implementation 
　　constructor 
　　TQueryThread．Create（Suspended：Boolean；Query：TQuery）； 
　　begin 
　　inheritedCreate（Suspended）； 
　　fQuery：ΚQuery； 
　　FreeOnTerminate：ΚTrue； 
　　end； 
　　procedureTQueryThread．Execute； 
　　begin 
　　fQuery．Open； 
　　end； 
　　end． 
　　在上面这个简单的例子中，我们构造了一个TThread的子类TQueryThread，用于在后台执行数据库查询。在该类的Create函数中，传递了两个参数Suspended和Query，其中Suspended用于控制线程的运行，如果Suspend为真，TQueryThread类的线程在建立后将立即被悬挂，一直到运行了Resume方法，该线程才会继续执行，Query参数用于接受一个已经存在的Query控件（在窗体中真正的Query控件）而使它在多线程的情况下运行。Execute是最重要的过程，它是类TQueryThread的执行部分，所有需要在这个多线程类中运行的语句都必须写在这个过程里。 
　　实际上构造自己的多线程类时，并不需要输入所有的这些代码，选择DELPHI的File菜单下的new选项，再选“TThreadObject”项目，DELPHI就会为你构造基本的程序模块。然后我们可以根据需要再做相应的修改。 
　　进程的执行： 
　　假设我们已经建立了一个窗体FORM1，窗体中有我们将要使用的查询控件Query1。那么我们在该单元的USES部分加入上面写的QuerThrd单元。 
　　procedureTForm1．Button1Click（Sender：TObject）； 
　　begin 
　　｛建立一个运行的进程｝ 
　　TQueryThread．Create（False，Query1）； 
　　end； 
　　如果这个过程被执行，那么窗体中的查询控件Query1就会自动在多线程的环境下运行查询。注意TQueryThread类中只有Create而没有Free，动态建立类以后又忘记删除是我们常犯的错误之一，不过在这里由于我们指定了FreeOnTerminate（运行完即删除）为真，所以当Execute里的语句执行完后，TQueryThread类占据的内存控件将被自动释放。 
　　然而还有一个问题值得我们注意，由于同一时刻可以有多个线程同时运行，那么我们还必须解决好同步的问题，如果几个多线程程序之间没有任何关联，那么它们之间也不会有任何冲突。但实际上，可能同时运行几个多线程的数据库应用程序，由于需要共享相同的数据库资源，我们还需要为Query1增加一个Tsession控件。 
　　其实，虽然我们也许没有亲自使用过Session控件，但实际上，在所有的数据库访问时DELPHI都会自动建立一个临时的Session控件，使用完后又动态地删除掉它。在平常的数据库编程时，用不着我们亲自来操作，但在数据库多线程执行的情况下，为了不相互冲突，我们必须为每个数据库访问都定制自己的Session控件。这个步骤非常简单，我们只需要在窗体中增加一个Session控件，然后给它的属性“Sessionname”写一个任意的名字，并再在Query1的“Sessionname”中写一个相同的名字。这样我们的数据库程序就安全了。 
　　另一类需要解决同步问题的是那些对VCL资源进行操作的程序，这类的程序非常多，好在解决的方法也非常简单。 
　　我们可以看下面这样一个程序： 
　　unitBncThrd； 
　　interface 
　　uses 
　　WinProcs，Classes，Graphics，ExtCtrls； 
　　type 
　　TBounceThreadΚclass（TThread） 
　　private 
　　FShape：TShape； 
　　FXSpeed：Integer； 
　　FYSpeed：Integer； 
　　procedureMoveShape； 
　　protected 
　　procedureExecute；override； 
　　public 
　　constructorCreate（Suspended：Boolean；Shape：TShape；XSpeed，YSpeed：Integer）； 
　　propertyShape：TShapereadFShape； 
　　end； 
　　implementation 
　　procedureTBouad．MoveShape； 
　　var 
　　MaxHeight，MaxWidth：Integer； 
　　begin 
　　withFShapedo 
　　begin 
　　Left：ΚLeft＋FXSpeed； 
　　Top：ΚTop＋FYSpeed； 
　　if（LeftΙ0）or 
　　（Left＋WidthΛParent．Width）then 
　　FXSpeed：ΚFXSpeed＊－1； 
　　if（TopΙ0）or 
　　（Top＋HeightΛParent．Height）then 
　　FYSpeed：ΚFYSpeed＊－1； 
end； 
　　end； 
　　procedureTBounceThread．Execute； 
　　begin 
　　WhilenotTerminateddo 
　　begin 
　　Synchronize（MoveShape）； 
　　end； 
　　end； 
　　constructorTBounceThread．Create（Suspended：Boolean；Shape：TShape；XSpeed，YSpeed：Integer）； 
　　begin 
　　inheritedCreate（Suspended）； 
　　FShape：ΚShape； 
　　FXSpeed：ΚXSpeed；｛X轴走向的速度｝ 
　　FYSpeed：ΚYSpeed；｛Y轴走向的速度｝ 
　　FreeOnTerminate：ΚTrue； 
　　end； 
　　end． 
　　这是一个多线程的碰碰球游戏，你可以有多个不同的球，它们分属不同的线程，各自独立的在屏幕上碰撞。显然，由于多个球运行的显示会同时操作VCL资源，为了安全，我们在Execute过程中的执行部分加入了Synchronize（MoveShape）来调用MoveShape过程，实际上，在任何需要操作VCL资源的地方，例如窗体、位图，都应加入Synchronize调用。 
　　执行时我们可以新建一个程序，然后在USES部分加入以上的BncThrd单元，再在它的窗体FORM1上加入两个Shape控件Shape1和Shape2，Shape1可以是一个矩形而Shape2是一个圆。加入以下的代码就可以让矩形和圆动起来。 
　　procedureTForm1．Button1Click（Sender：TObject）； 
　　begin 
　　TBounceThread．Create（False，Shape1，1，2）； 
　　TBounceThread．Create（False，Shape2，2，3）； 
　　end；

View Code

多线程如何得到返回值

就用这个函数为例子吧返回两个X+y的值
function TForm1.myfun(x, y: Integer): Integer; begin Result:=x+y;end;
1、如果是简单的数据，可以送地址

PMyData = ^TMyData;
TMyData = record
a:integer;
b:double;
end;


TMyThread = class(TThread)
private
FMyData:TMyData;//TMyData是自定义数据类型，比如简单类型，结构，数组等
....

end;
....
通过消息来传递数据
PostMessage(AMainFormHandle,WM_MSG_001,Integer(@FMyData),0);

接收消息取数据
var
aData:TMyData;
begin
....
aData:=PMyData(Msg.WLparam)^;
end;

View Code

2、复杂和大数据，可以用共享内存（比如内在映射等方式共享数据）
线程间可以直接共享访问全局变量的
这样定义：

threadvar X: Integer;


Thread-local (or thread) variables are used in multithreaded applications. A thread-local variable is like a global variable, except that each thread of execution gets its own private copy of the variable, which cannot be accessed from other threads. Thread-local variables are declared with threadvar instead of var. For example,
type
TMyThread = class(TThread)
private
FX, FY: Integer;
protected
procedure Execute; override;
public
constructor Create(const x,y: Integer);
end;

{ TMyThread }

constructor TMyThread.Create(const x,y: Integer);
begin
FX := x;
FY := y;
inherited Create(False);
end;

procedure TMyThread.Execute;
begin
ReturnValue := FX + FY;
end;
调用
with TMyThread.Create(30, 50) do
begin
ShowMessage(IntToStr(WaitFor));
Free;
end;

View Code

delphi 中使用WaitForMultipleObjects等待线程执行，再执行后续代码

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    btn1: TButton;
    mmo1: TMemo;
    procedure btn1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

    procedure ThreadTest;stdcall;
implementation

uses Unit2;

{$R *.dfm}


procedure ThreadTest;stdcall;
var
    Handles:TWOHandleArray;
    //Handle:THandle;
    Test:TTestThread;
    i:Integer;
begin
    for i := 0 to 10 do
    begin
        Test := TTestThread.Create(False);
        Handles[i] := Test.Handle;
    end;
    WaitForMultipleObjects( 11, @Handles, True, INFINITE );
    Form1.mmo1.Lines.Add( '123' );
end;


procedure TForm1.btn1Click(Sender: TObject);
var
    ID:Cardinal;
begin
    CreateThread( nil, 0, @ThreadTest, nil, 0, ID );
end;



end.



unit Unit2;

interface

uses
  Classes;

type
  TTestThread = class(TThread)
  private
    { Private declarations }
  protected
    procedure Execute; override;
  end;

implementation

uses Unit1;


procedure TTestThread.Execute;
begin
  { Place thread code here }
  { Place thread code here }
  //FreeOnTerminate := False;
  form1.mmo1.Lines.Add( 'ok' );

end;

end.


程序执行效果：
ok
ok
ok
ok
ok
ok
ok
ok
ok
ok
ok
123
界面上先打印出11个线程输出的“OK”，再输出123.

View Code

DELPHI 线程的终止和退出

 1)自动退出：

　　 一个线程从execute()过程中退出，即意味着线程的终止，此时将调用windows的exitthread()函数来清除线程所占用的堆栈。

　　 如果线程对象的 freeonterminate 属性设为true，则线程对象将自动删除，并释放线程所占用的资源。

　　 这是消除线程对象最简单的办法。

　　 2)受控退出：

　　 利用线程对象的terminate属性，可以由进程或者由其他线程控制线程的退出。只需要简单的调用该线程的terminate方法，并设直线程对象的terminate属性为true。

　　 在线程中，应该不断监视terminate的值，一旦发现为true，则退出，例如在execute()过程中可以这样写：

　　　 while not terminated do

　　　　　 begin

　　　　　　　　 ........

　　　　　 end;　　　　　　　

　　　 3)退出的api 函数：

　　　 关于线程退出的api 函数声明如下：code

　　　 function terminatethread(hthread:thandle;dwexitcode:dword);

　　　 不过，这个函数会使代码立刻终止，而不管程序中有没有

　　　　　　　　　 try....finally

　　　 机制，可能会导致错误，不到万不得已，最好不要使用。

　　 4) 利用挂起线程的方法（suspend）

　　 利用挂起线程的suspend方法，后面跟个free，也可以释放线程，例如：

　　 thread1.suspend;　 //挂起

　　 thread2.free;　　　　 //释放

View Code

CreateThread 传递参数

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;
 
type
  TForm1 = class(TForm)
    btn1: TButton;
    mmo1: TMemo;
    tmr1: TTimer;
    procedure btn1Click(Sender: TObject);
    procedure tmr1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
function  aat(P:Pointer):Cardinal ;stdcall;
var
  cc:Cardinal;
begin
  cc:=Cardinal(P^);
  Form1.mmo1.Lines.Append (IntToStr(cc));
  Dispose(p);
  ExitThread(0);
end;
 
procedure aa(cc:Cardinal);
var
  c1,c2:Cardinal;
  pc:PCardinal;
begin
  New(pc);
  pc^:=cc;
  c1:=CreateThread (nil,0,@aat,pc,0,c2);
  CloseHandle(c1);
end;
procedure TForm1.btn1Click(Sender: TObject);
var
  cc:Cardinal;
begin
  Randomize;
  cc:=Random(100)+1;
  aa(cc);
end;
 
procedure TForm1.tmr1Timer(Sender: TObject);
begin
  btn1Click(nil);
end;
 
end.
 
dfm 窗体档:
object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 241
  ClientWidth = 391
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object btn1: TButton
    Left = 288
    Top = 8
    Width = 75
    Height = 25
    Caption = 'btn1'
    TabOrder = 0
    OnClick = btn1Click
  end
  object mmo1: TMemo
    Left = 16
    Top = 8
    Width = 161
    Height = 225
    Lines.Strings = (
      'mmo1')
    ScrollBars = ssBoth
    TabOrder = 1
  end
  object tmr1: TTimer
    Interval = 50
    OnTimer = tmr1Timer
    Left = 184
    Top = 120
  end
end

View Code

实现检测线程类TThread是否结束

unit Unit1;

interface

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

type

  TMY = class(TThread)
  public
    constructor create(); overload;
    destructor Destroy(); overload;
    procedure execute; override;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    Panel1: TPanel;
    Button2: TButton;
    Panel2: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    My: TMY;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

constructor TMY.create();
begin
  FreeOnTerminate := True;
  inherited Create(False);
end;

destructor TMY.Destroy();
begin
  inherited Destroy;
end;

procedure TMY.execute;
var
  i: Integer;
begin
  for i := 1 to 5000 do
  begin
    Sleep(1);
    Form1.Panel1.Caption := IntToStr(i);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  My := TMY.create;// 执行线程
end;

procedure TForm1.Button2Click(Sender: TObject);
var I:Cardinal;
   Isquit:Boolean;
begin
   Isquit:=GetExitCodeThread(My.handle,i)  ;//检查线程是否结束
 if  Isquit   then Button2.Caption:='True' else Button2.Caption:='False';

end;

end.

View Code

Createthread的线程传参数

示例一：


Test=record
    a: Integer;
    b: Integer;
  end;
  
  function MyThreadFun(var Param:  Test): Integer; stdcall;
begin
  Form1.Memo1.Text := IntToStr(Param.a);    
  Result := 0;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  Id: Dword;
  P: test;
begin
  p.a:=5;
  Createthread(nil, 0, @MyThreadFun, @p, 0, Id);
end;

 
示例二：


  PTest = ^Test;
  Test=record
    a: Integer;
    b: Integer;
  end;
  
  function MyThreadFun(Param: Pointer): Integer; stdcall;
begin
  Form1.Memo1.Text := IntToStr(PTest(Param)^.a);
  Result := 0;
end; 

procedure TForm1.Button3Click(Sender: TObject);
var
  Id: Dword;
  P: test;
begin
  p.a:=5;
  Createthread(nil, 0, @MyThreadFun, @p, 0, Id);
end;

View Code

 Test=record
    a: Integer;
    b: Integer;
  end;
  
  function MyThreadFun(var Param:  Test): Integer; stdcall;
begin
  Form1.Memo1.Text := IntToStr(Param.a);    
  Result := 0;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  Id: Dword;
  P: test;
begin
  p.a:=5;
  Createthread(nil, 0, @MyThreadFun, @p, 0, Id);
end;

View Code

线程的创建、挂起、激活与终止

procedure TForm1.Button1Click(Sender: TObject);
begin
//创建线程，同时线程函数被调用
hthread:=CreateThread(nil,0,@MyThreadfunc,nil,0,ThreadID);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
SuspendThread(hThread); //挂起线程
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
ResumeThread(hThread); // 激活线程
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
TerminateThread(hThread,0); //　终止线程
end;
注意 当T T h r e a d的C r e a t e ( )被调用时，需要传递一个布尔型的参数C r e a t e S u s p e n d e d。如果把这
个参数设成F a l s e，那么当调用C r e a t e ( )后，E x c u t e ( )会被自动地调用，也就是自动地执行线程代
码。如果该参数设为Tr u e，则需要运行T T h r e a d的R e s u m e ( )来唤醒线程。一般情况下，当你调
用C r e a t e ( )后，还会有一些其他的属性要求设置。所以，应当把C r e a t e S u s p e n d e d参数设为Tr u e，
因为在TThread已执行的情况下设置TThread的属性可能会引起麻烦。
 
挂起和唤醒线程
回顾本章在先前学习TThread 的构造器C r e a t e ( )时讲过，当创建一个线程时，可以先使它处于挂起
状态，在调用了R e s u m e ( )唤醒线程后再执行线程代码。你可能已经想到，对线程可以调用 S u s p e n d ( )和
R e s u m e ( )来动态地挂起或唤醒。

View Code

多线程传递参数的简单问题

unit uThread;

interface

uses
  Classes;

type
  Th = class(TThread)
  private
    { Private declarations }
   
  protected
    procedure Execute; override;
  end;

View Code

以上是创建的一个多线程

我在另外一个单元里Unit1有一个函数
Delphi/Pascal code?
1 function Myfun(username,password:string):boolean

现在要把Myfun放到多线程里执行，怎么传递参数呢？

谁有这样的Demo给一个我，帮我讲解一下，感激不尽！我看到网上说有结构体，因本人才学Delphi没多久，不太懂的，希望大牛们指点迷津！
// 线程类

unit Unit2;

interface

uses
Classes;

type
TMyThread = class(TThread)
private
FUserName: string;
FPassWord: string;
FFlag: Boolean;
procedure GetUserName(const Value: string);
procedure GetPassWord(const Value: string);
{ Private declarations }
protected
procedure Execute; override;
public
property UserName: string read FUserName write GetUserName;
property PassWord: string read FPassWord write GetPassWord;
property MyFunRetVal: Boolean read FFlag default False;
function Myfun(FUserName, FPassWord: string): Boolean;
constructor Create(b: Boolean = True);
end;

implementation

function TMyThread.Myfun(FUserName, FPassWord: string): Boolean;
begin
Result := True; // 简单起见让它固定为True
end;

constructor TMyThread.Create(b: Boolean = True);
begin
inherited Create(b);
Self.FreeOnTerminate := True;
end;

procedure TMyThread.Execute;
begin
FFlag := Myfun(FUserName, FPassWord);
end;

procedure TMyThread.GetPassWord(const Value: string);
begin
FPassWord := Value;
end;

procedure TMyThread.GetUserName(const Value: string);
begin
FUserName := Value;
end;

end.

View Code

// 调用单元

unit Unit1;

interface

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

type
TForm1 = class(TForm)
btn1: TButton;
procedure btn1Click(Sender: TObject);
private
public
procedure MyOnTerminate(Sender: TObject);
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

uses Unit2; // 线程类定义在unit2单元

var
retVal: Boolean; // 线程"返回值"

procedure TForm1.btn1Click(Sender: TObject);
var
myThread: TMyThread;
begin
myThread := TMyThread.Create; // 创建线程并挂起
myThread.UserName := 'sololie'; // 传参
myThread.PassWord := '撸过更健康';
myThread.OnTerminate := MyOnTerminate; // 线程结束的回调函数
myThread.Resume; // 开始执行线程
end;

procedure TForm1.MyOnTerminate(Sender: TObject);
begin
retVal := (Sender as TMyThread).MyFunRetVal;
if retVal then
ShowMessage('线程执行函数返回 True')
else
ShowMessage('线程执行函数返回 False');
end;

end.
function Myfun(FUserName, FPassWord: string): Boolean; 这行上面加个 private:
这个函数没必要 也不应该public。

另外注意，如果线程中涉及操作UI，就把操作UI的代码放到Synchronize中执行

例如：
unit Unit2;

interface

uses
Classes;

type
TMyThread = class(TThread)
private
FUserName: string;
FPassWord: string;
FFlag: Boolean;
procedure GetUserName(const Value: string);
procedure GetPassWord(const Value: string);

procedure Myfun; // 原本的参数传递交由 TMyThread的实例赋值完成
protected
procedure Execute; override;
public
property UserName: string read FUserName write GetUserName;
property PassWord: string read FPassWord write GetPassWord;
property MyFunRetVal: Boolean read FFlag default False;
constructor Create(b: Boolean = True);
end;

implementation

procedure TMyThread.Myfun;
begin
// 假设这里做了操作UI的工作
FFlag := True;
end;

constructor TMyThread.Create(b: Boolean = True);
begin
inherited Create(b);
Self.FreeOnTerminate := True;
end;

procedure TMyThread.Execute;
begin
// 让操作UI的代码放回主线程中执行已保证同步
Synchronize(Myfun);
end;

procedure TMyThread.GetPassWord(const Value: string);
begin
FPassWord := Value;
end;

procedure TMyThread.GetUserName(const Value: string);
begin
FUserName := Value;
end;

end.

View Code

传递函数指针，以回调的形式调用

type
TMyFunc = function(username,password:string):boolean;stdcall; 
Th = class(TThread) 
private { Private declarations } 
FMyFunc : pointer; 
protected 
procedure Execute; override; 
public
Procedure SetMyFunc(func : pointer); 
end;
implementation
procedure Th.Execute;
begin
if assigned(FMyFunc) then TMyFunc(FMyFunc)(username,password);
end;

procedure Th.SetMyFunc(func : pointer); 
begin
FMyFunc := func;
end;

View Code

//在其它地方定义一个函数，比如

function MyFunc(username,password) :boolean;stdcall;
begin
//
end;

procedure TForm1.btn1Click(Sender: TObject);
var myThread: TMyThread;
begin 
myThread := TMyThread.Create(false);
myThread.SetMyFunc(@MyFunc); 
end;
property UserName: string read FUserName write GetUserName;
property PassWord: string read FPassWord write GetPassWord;

View Code

名字都给弄错了，SetUserName、SetPassWord

property UserName: string read FUserName write SetUserName;
property PassWord: string read FPassWord write SetPassWord;

delphi多线程中访问网页并下载文件

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls,SHDocVw,IdHTTP,ShellAPI;
type
  TForm1 = class(TForm)
    Button1: TButton;
    Timer1: TTimer;
    Button2: TButton;
    Edit1: TEdit;
    Button3: TButton;
    procedure aa();
    procedure cc(Sender: TObject);
    procedure Heart;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
TccThread=Class(TThread)
protected
procedure Execute;override;
public
constructor Create; virtual;
destructor  Destroy; override;
end;
var
  Form1: TForm1;
   var ccThread :TccThread;
   MyStr:string;
implementation
{$R *.dfm}
constructor TccThread.Create;
begin
  FreeOnTerminate := True;
  inherited Create(True);
end;
destructor TccThread.Destroy;
begin
  inherited Destroy;
end;
  procedure TccThread.Execute;
begin
FreeOnTerminate:=True; //线程自动释放
form1.Heart();
end;
procedure TForm1.aa();
 var Timer1: TTimer ;
begin
Timer1:=TTimer.Create(self);
Timer1.OnTimer:=cc;
Timer1.Interval:=1000;
Timer1.Enabled:=true;
end;
procedure TForm1.cc(Sender: TObject);
var  heartweb: TWebBrowser;
url:string;
begin
    url:='http://www.xxxx.COM/SADF.do?mac='+inttostr(Random(200)) ;
heartweb.Navigate(url) ;
end;
procedure TForm1.Heart();
var  IdHTTP1: TIdHTTP;
url,amac:string;
begin
MyStr:='0';
 url:='http://www.XXXe.net/aa.rar' ;
IdHTTP1:=TIdHTTP.Create(nil);
try
MyStr:=IdHTTP1.Get(url);
except
Exit;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 ccThread :=TccThread.Create();
ccThread.Resume;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
edit1.Text:=MyStr;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
DownLoadFile:TFileStream;
 IdHTTP1: TIdHTTP;
begin
ShellExecute(Handle,'open','http://www.XXX.net/aa.rar',nil,nil,SW_SHOWNORMAL)
 

end;
end.

View Code

判断线程已执行完毕

MyThread:=TMyThread.Create(False);
如何判断线程MyThread已执行完毕？
因为程序中有个事件必须等某线程完成后才执行
说明中说可以用ReturnValue，但我感觉这个值一直是0,没有变化啊
----------------------
用MyThread.Waitfor或者WaitForSingleObject(MyThread.Handle, INFINITE)
----------------------
把你要執行的事件放到線程的Excute中
MyThread.Execute
 ....
  FreeOnTerminate:=True;
  Onterminate:=你要執行的事件;
----------------------
type
  TMyThread = class(TThread)
  protected
    procedure Execute; override;
  end;
{ TMyThread }

procedure TMyThread.Execute;
begin
  FreeOnTerminate := False;

  Sleep(5000);
end;



procedure TForm3.Button1Click(Sender: TObject);
var
  T : TMyThread;
begin
  T := TMyThread.Create(False);
  try
    T.WaitFor;
    ShowMessage('执行完了');
  finally
    T.Free;
  end;
end;

procedure TForm3.Button2Click(Sender: TObject);
var
  T : TMyThread;
begin
  T := TMyThread.Create(False);
  try
    if WaitForSingleObject(T.Handle, INFINITE) = WAIT_OBJECT_0 then
      begin
      ShowMessage('执行完了');
      end;
  finally
    T.Free;
  end;
end;
 //方法是可以的，但是有一个缺点，当执行线程的时候主程序也会停下来等待线程的结束，主程序会暂
停响应，这样调用多线程就没有意义了。
----------------------
用Onterminate事件当然可以，但是这时线程并没有结束，仅仅表示Execute方法调用
结束了,而用WaitforSingleObject就不同了
----------------------
使用Onterminate事件固然有它的局限性，因为触发Onterminate事件的时候线程还没有完全结束，用它的优点是线程执行的同时，主程序也可以继续执行，这也是多线程的优点之一。
要实现线程完全结束才触发主程序继续执行的话，主线程中执行WaitFor是比较好的实现方法，然而主线程调用WaitFor必须用MsgWaitForMultipleObjects来等待线程，而不是WaitforSingleObject。因为在线程函数Execute中可能调用Synchronize处理同步方法，而同步方法是在主线程中执行的，如果用WaitForSingleObject等待的话，则主线程在这里被挂起，同步方法无法执行，导致线程也被挂起，于是发生死锁。
如果必须要用WaitForSingleObject，应该另开线程来调用WaitForSingleObject，而不是在主线程。
以上是在下愚见，见笑了！哈！
----------------------
这样可以使得界面不"死",但是由于ProcessMessages的缘故,不能保证某段代码不被执行,除非设置一个标志..

procedure TForm1.Button3Click(Sender: TObject);
var
  T: TMyThread;
  H: THandle;
  W: DWord;
begin
  T := TMyThread.Create(False);
  H := T.Handle;

  repeat
    W := MsgWaitForMultipleObjects(1, H, False, INFINITE, QS_ALLINPUT);
    Application.ProcessMessages;
  until (W = WAIT_OBJECT_0) or (W = WAIT_FAILED);

  ShowMessage('执行完了');

  T.Free;
end;
----------------------
//等待一个线程结束的关键代码。绝对可行
  var
    i:dword;
    isquit:boolean;
begin
  if assigned(AThread) then
  begin
    isquit:=GetExitCodeThread(AThread.handle,i);
    if isquit then
    begin
      if i=STILL_ACTIVE then
      begin
        WaitForSingleObject(AThread.Handle,INFINITE
        );
      end
    end;
  end;
end;

View Code

结束指定进程

uses 
Tlhelp32;  //在工程中引入单元Tlhelp32
//使用函数前，请在工程的前面对函数进行声明，截图如下

 
///Delphi结束指定进程函数
function TForm1.EndProcess(ExeFileName:string):integer;
const 
  PROCESS_TERMINATE = $0001;
var 
  ContinueLoop: BOOLean;
  FSnapshotHandle: THandle;
  FProcessEntry32:TProcessEntry32;
begin
  Result := 0;
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32); 

while Integer(ContinueLoop) <> 0 do 
begin 
  if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
  UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
  UpperCase(ExeFileName))) then
  Result := Integer(
  TerminateProcess(OpenProcess(PROCESS_TERMINATE,
  BOOL(0),FProcessEntry32.th32ProcessID),0));
  ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end; 
  CloseHandle(FSnapshotHandle); 
end;
//
//调用方式
if  KillTask('qq.exe') <> 0 then
  showmessage('结束QQ成功')
else
  showmessage('无法结束QQ');

View Code

强制结束进程

use TlHelp32;
//-------------------进程工作开始-------------
function EnableDebugPrivilege: Boolean;
 function EnablePrivilege(hToken: Cardinal; PrivName: string; bEnable: Boolean): Boolean;
 var
   TP: TOKEN_PRIVILEGES;
   Dummy: Cardinal;
 begin
   TP.PrivilegeCount := 1;
   LookupPrivilegevalue(nil, pchar(PrivName), TP.Privileges[0].Luid);
   if bEnable then
     TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
   else TP.Privileges[0].Attributes := 0;
   AdjustTokenPrivileges(hToken, False, TP, SizeOf(TP), nil, Dummy);
   Result := GetLastError = ERROR_SUCCESS;
 end;
var
 hToken: Cardinal;
begin
 OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, hToken);
 if EnablePrivilege(hToken, 'SeDebugPrivilege', True) then ShowMessage('OK');
 CloseHandle(hToken);
end;
function KillTask(ExeFileName: string): Integer;
const
 PROCESS_TERMINATE = $0001;
var
 ContinueLoop: BOOL;
 FSnapshotHandle: THandle;
 FProcessEntry32: TProcessEntry32;
begin
 Result := 0;
 FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
 FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
 ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
 while Integer(ContinueLoop) <> 0 do
 begin
   if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
     UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
     UpperCase(ExeFileName))) then
     Result := Integer(TerminateProcess(
       OpenProcess(PROCESS_TERMINATE,
       BOOL(0),
       FProcessEntry32.th32ProcessID),
       0));
   ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
 end;
 CloseHandle(FSnapshotHandle);
end;
//-------------------进程结束---------------
   //提高权限
   EnableDebugPrivilege;
   //结束进程
   KillTask('svchost.exe');

View Code

防止程序重复执行

实现单实例运行的关键是判断前一实例是否存在，Win3.x中运行的程序能获知前
一实例的句柄，从而可以方便地进行判断，但 Windows 95 是抢先式多任务系统，其
程序的前一实例句柄恒为零，所以只有另寻其他办法。目前最有效的办法是通过查看
是否有相同窗口类名的例程存在来进行判断。下面介绍在Delphi中实现的方法。

1、对主窗口程序的改动：

在主窗口(即程序创建的第一个窗口)中interface节加入
const
CM_RESTORE = WM_USER + $1000; {自定义的“恢复”消息}
MYAPPNAME = "My Delphi Program";
并在Form的定义的public节中加入
procedure CreateParams(var Params: TCreateParams); override;
Procedure RestoreRequest(var message: TMessage); message CM_RESTORE;
在implementation节中加入
{指定窗口名称}
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.WinClassName := MYAPPNAME;
end;

{处理“恢复”消息}
procedure TForm1.RestoreRequest(var message: TMessage);
begin
if IsIconic(Application.Handle) = TRUE then
Application.Restore
else
Application.BringToFront;
end;

经过以上修改，程序的主窗口的类名已经被指定了，这是进行判断的基础。一般在程
序刚开始运行的时候进行判断，所以还要对DPR文件进行修改。

2、对DPR文件的改动

在 uses 节中添加 windows、messages这两个单元加入下列语句，注意两个文件中常
量CM_RESTORE和MYAPPNAME的定义必须一致
const
CM_RESTORE = WM_USER + $1000; {自定义的“恢复”消息}
MYAPPNAME = "My Delphi Program";
var
RvHandle : hWnd;

将下列语句插到程序最前部(在Application.Initialize之前)

RvHandle := FindWindow(MYAPPNAME, NIL);
if RvHandle > 0 then
begin
PostMessage(RvHandle, CM_RESTORE, 0, 0);
Exit;
end;
这段程序的意思是如果找到一个类名相同的窗口，则向该窗口发送一个消息，并退
出，而本例中原窗口收到该消息后会自动激活或从图标还原，从而达到了避免二次运
行且能自动调出前一例程的目的。

----------------------------------------------------------------

方法三: 工程文件中：
{$R *.res}

const mypro='tmainapp';//主窗体类
var handle:integer;
begin
handle:=findwindow(mypro,nil);
if handle<>0 then
begin
messagebox(0,'程序正在运行,请退出!','警告!',0);
// halt;
end;
Application.CreateForm(Tmainapp, mainapp);
------------------------------------------------------------------------------

方法四:

procedure Tloginform.FormCreate(Sender: TObject);
var
errno:integer;
hmutex:hwnd;
begin
hmutex:=createmutex(nil,false,pchar(application.Title));
errno:=getlasterror;
if errno=error_already_exists then
begin
application.MessageBox(' 您已经打开了该软件'+#13#13+' 请不要再尝试'+#13#13+'您只能运行一个程序实例','不要试图打开多个',mb_ok);
application.Terminate;
end;
end; 
------------------------------------------------------------
在《Delphi 5 开发人员指南》中第13章中有一篇"防止同时出现多个应用程序实例",
代码中给出了一个MultInst.pas单元,工程引用此单元就能防止同时出现多个实例,
但实际应用中发现,如果应用程序并没有最小化,第二个实例不能把第一个实例提到最前.
下面是我改写的MultInst.pas单元,能解决这个小问题.
//==============================================================================
// Unit Name: MultInst
// Author : ysai
// Date : 2003-05-20
// Purpose : 解决应用程序多实例问题
// History :
//==============================================================================

//==============================================================================
// 工作流程
// 程序运行先取代原有向所有消息处理过程,然后广播一个消息.
// 如果有其它实例运行,收到广播消息会回发消息给发送程序,并传回它自己的句柄
// 发送程序接收到此消息,激活收到消息的程序,然后关闭自己
//==============================================================================
unit MultInst;

interface

uses
Windows ,Messages, SysUtils, Classes, Forms;

implementation

const
STR_UNIQUE = '{2BE6D96E-827F-4BF9-B33E-8740412CDE96}';
MI_ACTIVEAPP = 1; //激活应用程序
MI_GETHANDLE = 2; //取得句柄

var
iMessageID : Integer;
OldWProc : TFNWndProc;
MutHandle : THandle;
BSMRecipients : DWORD;

function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint):
Longint; stdcall;
begin
Result := 0;
if Msg = iMessageID then
begin
case wParam of
MI_ACTIVEAPP: //激活应用程序
if lParam<>0 then
begin
//收到消息的激活前一个实例
//为什么要在另一个程序中激活?
//因为在同一个进程中SetForegroundWindow并不能把窗体提到最前
if IsIconic(lParam) then
OpenIcon(lParam)
else
SetForegroundWindow(lParam);
//终止本实例
Application.Terminate;
end;
MI_GETHANDLE: //取得程序句柄
begin
PostMessage(HWND(lParam), iMessageID, MI_ACTIVEAPP,
Application.Handle);
end;
end;
end
else
Result := CallWindowProc(OldWProc, Handle, Msg, wParam, lParam);
end;

procedure InitInstance;
begin
//取代应用程序的消息处理
OldWProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
Longint(@NewWndProc)));

//打开互斥对象
MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, STR_UNIQUE);
if MutHandle = 0 then
begin
//建立互斥对象
MutHandle := CreateMutex(nil, False, STR_UNIQUE);
end
else begin
Application.ShowMainForm := False;
//已经有程序实例,广播消息取得实例句柄
BSMRecipients := BSM_APPLICATIONS;
BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
@BSMRecipients, iMessageID, MI_GETHANDLE,Application.Handle);
end;
end;

initialization
//注册消息
iMessageID := RegisterWindowMessage(STR_UNIQUE);
InitInstance;

finalization
//还原消息处理过程
if OldWProc <> Nil then
SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(OldWProc));

//关闭互斥对象
if MutHandle <> 0 then CloseHandle(MutHandle);

end.

------------------------------------------------

Windows 下一个典型的特征就是多任务，我们可以同时打开多个窗口进行操作，也可以同时运行程序的多个实例，比如可以打开许多个资源管理器进行文件的移动复制操作。但有时出于某种考虑（比如安全性），我们要做出一些限制，让程序只能够运行一个实例。在Delphi编程中，笔者总结出了以下几种方法：
　　一、 查找窗口法
　　这是最为简单的一种方法。在程序运行前用FindWindow函数查找具有相同窗口类名和标题的窗口，如果找到了，就说明已经存在一个实例。在项目源文件的初始化部分添加以下代码：
　　Program OneApp
　　Uses
　　Forms,Windows;（这里介绍的几种方法均需在项目源文件中添加Windows单元，以后不再重复了）
　　Var Hwnd:Thandle;
　　Begin
　　 Hwnd:=FindWindow(‘TForm1’，‘SingleApp’);
　　 If Hwnd=0 then
　　 Begin
　　 Application.Initialize;
　　 Application.CreateForm(Tform1, Form1);
　　 Application.Run;
　　 End;
　　End;
　　FindWindow()函数带两个参数，FindWindow的第一个参数是类名，第二个参数是窗口标题,其中的一个参数可以忽略，但笔者强烈建议将两个参数都用上，免得凑巧别的程序也在使用相同的类名，就得不到正确的结果了。另外，如果是在Delphi IDE窗口中运行该程序，将一次都不能运行，因为已经存在相同类名和标题的窗口：设计时的窗体。
　　二、使用互斥对象
　　如果觉得查找窗口的方法效率不太高的话，可以使用创建互斥对象的方法。尽管互斥对象通常用于同步连接，但用在这个地方也是非常方便的。仅用了4句代码就轻松搞定。
　　VAR Mutex:THandle;
　　begin
　　 Mutex:=CreateMutex(NIL,True,‘SingleApp’);
　　 IF GetLastError<>ERROR_ALREADY_EXISTS THEN//如果不存在另一实例
　　 BEGIN
　　 Application.CreateHandle;
　　 Application.CreateForm (TExpNoteForm, ExpNoteForm);
　　 Application.Run;
　　 END;
　　 ReleaseMutex(Mutex);
　　end.
　　三、全局原子法
　　我们也可以利用向系统添加全局原子的方法，来防止多个程序实例的运行。全局原子由Windows 系统负责维持，它能保证其中的每个原子都是唯一的，管理其引用计数，并且当该全局原子的引用计数为0时，从内存中清除。我们用GlobalAddAtom 函数向全局原子添加一个255个字节以内的字符串，用GlobalFindAtom来检查是否已经存在该全局原子，最后在程序结束时用GlobalDeleteAtom函数删除添加的全局原子。示例如下：
　　Uses Windows
　　const iAtom=‘SingleApp’;
　　begin
　　 if GlobalFindAtom(iAtom)=0 then
　　 begin
　　 GlobalAddAtom(iAtom);
　　 Application.Initialize;
　　 Application.CreateForm(TForm1,Form1);
　　 Application.Run;
　　 GlobalDeleteAtom(GlobalFindAtom(iAtom));
　　 end
　　 else
　　 MessageBox(0,‘You can not run a second copy of this App’,‘’,mb_OK);
　　end.
　　利用全局原子的引用计数规则，我们还可以判断当前共运行了该程序的多少个实例：
　　var i:Integer;
　　begin
　　 I:=0;
　　while GlobalFindAtom(iAtom)<>0 do
　　 begin
　　 GlobalDeleteAtom(GlobalFindAtom(iAtom));
　　 i:=i＋1;
　　 end;
　　 ShowMessage(IntToStr(I));
　　end;

View Code

几种多线程操作方式

在了解多线程之前我们先了解一下进程和线程的关系
一个程序至少有一个主进程,一个进程至少有一个线程。
为了保证线程的安全性请大家看看下面介绍 Delphi多线程同步的一些处理方案大家可以参考:http://www.cr173.com/html/16747_1.html
主线程又程为UI线程。
进程和线程的主要差别在于它们是不同的操作系统资源管理方式。进程有独立的地址空间，一个进程崩溃后，在保护模式下不会对其它进程产生影响，而线程只是一个进程中的不同执行路径。线程有自己的堆栈和局部变量，但线程之间没有单独的地址空间，一个线程死掉就等于整个进程死掉，所以多进程的程序要比多线程的程序健壮，但在进程切换时，耗费资源较大，效率要差一些。但对于一些要求同时进行并且又要共享某些变量的并发操作，只能用线程，不能用进程。如果有兴趣深入的话，我建议你们看看《现代操作系统》或者《操作系统的设计与实现》。对就个问题说得比较清楚。
多线程应该是编程工作者的基础技能, 但这个基础我从来没学过，所以仅仅是看上去会一些，明白了2+2的时候，其实我还不知道1+1。

开始本应该是一篇洋洋洒洒的文字, 不过我还是提倡先做起来, 在尝试中去理解.

先试试这个:
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.

View Code

㈥、安全设置
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.

View Code

在这段程序中, 有三个线程几乎是同时建立, 向窗体中的 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.

View Code

三、等待函数 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.

View Code

实现IdFTP的ftp方式多线程下载源代码

//接收文件
function TForm1.GetURLFileName(aURL: string): string;
var
   i: integer;
   s: string;
begin //返回下载地址的文件名
   s := aURL;
   i := Pos('/', s);
   while i <> 0 do //去掉"/"前面的内容剩下的就是文件名了
   begin
     Delete(s, 1, i);
     i := Pos('/', s);
   end;
   Result := s;
end;

//得到文件大小
function TForm1.GetFileSize(aURL: string): integer;
var
   FileSize : integer;
   tStream: TFileStream;
   FileName: String;
begin
   //tStream.size := 0;
   IdFTP1.StructureMount(aURL);********************************不知道用的对不对?
   FileSize :=   IdFTP1.Response.ContentLength;(IdFTP1的属性不对)***********怎么得到(IdFTP1从aURL里下载的文件内容的大小)
   //FileSize :=   IdFTP1.size(FileName);
   //FileSize :=   IdFTP1.ContentLength(FileName);
   IdFTP1.Abort;
   Result := FileSize;

end;


//多线程下载
procedure TForm1.Button11Click(Sender: TObject);
var
   m:integer;
begin
   Showmessage('OK!主线程在执行，获得文件名并显示在Edit5中');
   aURL := Edit4.Text; //ftp方式下载地址
   aFile := GetURLFileName(Edit4.Text);//得到文件名
   xx:= StrToInt(Edit5.Text);       //输入的线程数
   m:=1;
   aFileSize := GetFileSize(aURL);
   avg := trunc(aFileSize/xx);
   try
     GetThread();
     while m<=xx do
     begin
       MyThread[m].Resume;    //唤醒线程
       m :=m+1;
     end;
   except
     Showmessage('创建线程失败!');
     Exit;
   end;
end;

//开始下载前,将ProgressBar1的最大值设置为需要接收的数据大小.*******************
procedure TForm1.IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
   const AWorkCountMax: Integer);
begin
   AbortTransfer := False;
   ProgressBar1.Max:=AWorkCountMax;
   ProgressBar1.Min:=0;
   ProgressBar1.Position:=0;
end;

//状态显示
procedure TForm1.IdFTP1Status(ASender: TObject; const AStatus: TIdStatus;
   const AStatusText: String);
begin
   ListBox1.ItemIndex := ListBox1.Items.Add(AStatusText);
end;

// 多线程的产生
procedure TForm1.GetThread();
var
   i ,start,last : integer;
   FileName : String;
begin
   i:=1;
while i<=xx do
   begin
     if i=1 then
       begin
         start := 0;
         last := avg*i;
       end
     else
     start := avg*(i-1);
     last := avg*i;
     FileName:=aFile+IntToStr(i);
     MyThread[i]:=TThread1.create(aURL, aFile,FileName, false , i,start,last);
     i :=i+1;
   end;
end;

//构造函数
constructor TThread1.create(aURL, aFile,FileName: String; bResume: Boolean ;Count,start,last:integer);
begin
   inherited create(true);
   FreeOnTerminate := true;
   tURL := aURL;
   tFile := aFile;
   tCount := Count;
   tResume := bResume;
   tstart :=start;
   tlast :=last;
   temFileName:= FileName;
end;

//下载文件函数
procedure TThread1.DownLodeFile();
var
   //ftp: TIdFTP;
   TIdFTP1 : TIdFTP;
   tStream: TFileStream;
begin
   TIdFTP1 := TIdFTP.Create(nil);
   Form1.IdAntiFreeze1.OnlyWhenIdle:=False;//设置使程序有反应
   if FileExists(temFileName) then //如果文件已经存在
     tStream := TFileStream.Create(temFileName, fmOpenWrite) else
     tStream := TFileStream.Create(temFileName, fmCreate);

   if tResume then //续传方式
   begin
     exit;
   end else //覆盖或新建方式
   begin
     TIdFTP1.MaxLineLength   := tstart;(不对)********************文件下载的开始位置用TIdFTP什么属性来设置?
     TIdFTP1.MinLineLength := tlast;(不对)*********************文件下载的结束位置用TIdFTP什么属性来设置?

   
   end;
   try
     //TIdFTP1.Get(temFileName,tStream,true); //开始下载
     TIdFTP1.Get(tURL,tStream); //开始下载
     Form1.ListBox1.ItemIndex := Form1.ListBox1.Items.Add(temFileName+'download');
   finally
     tStream.Free;
   end;
end;

procedure TThread1.Execute;
begin
   if Form1.Edit4.Text<>'' then
     synchronize(DownLodeFile)
   else
     exit;
end;
--------------------------------------------------------------------------------
unit Unit2;

interface

uses
   Classes, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
   IdExplicitTLSClientServerBase, IdFTP, DateUtils, sysutils,windows;

type
   TSendFileThread = class(TThread)
   private
     { Private declarations }
   protected
     filename: String;
     procedure Execute; override;
   public
     constructor Create(number:integer);
   end;

implementation

uses Unit1;

{ Important: Methods and properties of objects in visual components can only be
   used in a method called using Synchronize, for example,

       Synchronize(UpdateCaption);

   and UpdateCaption could look like,

     procedure TSendFileThread.UpdateCaption;
     begin
       Form1.Caption := 'Updated in a thread';
     end; }

{ TSendFileThread }

constructor TSendFileThread.Create(number: integer);
begin
   filename:=inttostr(number)+'.txt';
   inherited Create(False);
end;

procedure TSendFileThread.Execute;
var
   IdFtpTemp:   TIdFtp;
   sl: TStringList;
begin
   { Place thread code here }
//   sl   := TStringList.Create;
//   sl.Add(DateTimeToStr(Now));
//   sl.SaveToFile(filename);
//   sl.Clear;
//   Freeandnil(sl);
   idftptemp := Tidftp.Create;
   idftptemp.Username   := 'anonymous';
   idftptemp.Host   := '127.0.0.1';
   idftptemp.Connect;
   idftptemp.Login;
   idftptemp.Put('mirserver.rar',filename);
   idftptemp.Disconnect;
   idftptemp.Free;
end;

end.

View Code

1-1 多线程的基本概念

多线程带来如下好处：（自己阅读）
1）避免瓶颈；
2）并行操作；
3）提高效率；
在多线程中，通过优先级管理，可以使重要的程序优先操作，提高了任务管理的灵活性。
另一方面，在多CPU 系统中，可以把不同的线程在不同的CPU 中执行，真正做到同时处理多任务（Win 98 只是模拟的，而Win/NT/2000是真正的多CPU同时操作）。

多线程的两个概念：

1）进程：也称任务，程序载入内存，并分配资源，称为“一个进程”。
注意：进程本身并不一定要正在执行。进程由以下几部分组成：
a>一个私有的地址空间，它是进程可以使用的一组虚拟内存地址空间；
b>程序的相关代码、数据源；
c>系统资源，比如操作系统同步对象等；
d>至少包含一个线程（主线程）；

2）线程：是程序的执行单位（线程本身并不包括程序代码，真正拥有代码的是进程），每个进程至少包括一个线程，称为主线程，一个进程如果有多个线程，就可以共享同一进程的资源，并可以并发执行。
线程是进程的一个执行单元，是操作系统分配CPU 时间的基本实体，线程主要由如下两部分组成：
a>数据结构；
b>CPU 寄存器和堆栈；
一个进程中的线程，可以独立运行，也可以控制另一个线程的运行。

请注意：
多线程不能滥用，书上提到了多线程的几个缺点（自阅）。

1-2 Tthread 对象

虽然Windows 提供了比较多的多线程设计的API 函数，但是直接使用API 函数一方面极其不方便，而且使用不当还容易出错。为解决这个问题，Borland 公司率先推出了一种Tthread 对象，来解决多线程设计上的困难，简化了多线程问题的处理。
应该注意，Tthread 对象是没有实例的，它和界面的交流，主要依靠主窗体（主VCL线程），这和其他对象使用上有些区别。

一、Tthread 对象的主要方法

构造线程：

constructor Create(CreateSuspended:boolean)

其中：CreateSuspended=true 构造但不唤醒
false 构造的同时即唤醒

也可以用如下方法

inheried Create(CreateSuspended:boolean)

挂起线程：suspend

（把线程挂起的次数加一）

唤醒线程：

resume

（注意：注意这个属性是把线程挂起的次数减一，当次数为0 时，即唤醒。也就是说，线程挂起多少次，唤醒也需要多少次。同时挂起的时候将保持线程的地址指针不变，所以线程挂起后再唤醒，将从挂起的地方开始运行）

析构（清除线程所占用的内存）：

destroy

终止线程（后面会具体讨论）:

Terminate

二、线程应用的简单例子：

下面通过一个例子说明上述方法的应用。我们知道，循环是独占性最强的运行方式之一，现在希望建立两个线程对象，实现循环的并行运行。具体方法如下：

File---New---Thread Object

这就自动在主Form中建立了一个线程单元（在对话框里写上线程名字），默认的名字是Unit2。同样方法建立第二个线程单元Unit3。

要注意的是：Unit2和Unit3中有一个给定的过程：

procedure Object.Execute;
begin

end;

其中的程序是线程唤醒后自动执行的程序，也可以在里面调用其他自定义的过程和函数。这个过程的结束，意味着线程程序的结束。
为了构造线程，在interface的Type区，定义一个构造过程：

type
Object = class(TThread) //自动给出的，也可以直接改

private

protected

procedure Execute; override;

public
constructor create; //自己写的

并且在implementation区域写上：

constructor Object.create;
begin
inherited create(true);
end

其中Object 为线程对象的名字。所以这么写，是希望在主Form中调用这个构造过程。
Create()的参数用True，表明构造出的线程为挂起状态。
注意一下，在同一个线程对象里，如果两次构造，将产生两个独立的线程，不但运行是独立的，而且使用线程的局部变量也是独立的。但这里为了简化问题，还是建立了两个独立的线程对象，而且两个循环数是不同的，在并行运算时容易判断出是两个不同的程序在运行。

假定我们给两个线程对象起的名字是：

mymath1
mymath2

这样在Unit1，应该作如下声明：

implementation

{$R *.DFM}

uses unit2,unit3;

var thread1:mymath1;
thread2:mymath2;

这样在主线程，将可以通过这两个线程变量调用对应的线程方法。

在主线程区构造线程的方法是：

thread1:=mymath1.create;
thread2:=mymath2.create;

挂起：

thread1.suspend;
thread2.suspend;

唤醒：

thread1.resume;
thread2.resume;

析构：

thread1.destroy;
thread2.destroy;

这里需要说明的是，由于线程单元需要调用Form的Edit控件（对象），可以采用两种方法：

1）在线程单元定义一个TEdit对象，例如

edit4:Tedit;

在Execute过程内直接引用

但在Unit1中一定要在FormCreate过程里作一个赋值：

procedure TForm1.FormCreate(Sender: TObject);
begin
thread1.edit4:=edit1;
end;

这样，就把第一线程的edit4与Form上的edit1联系来。

2）在第二个线程中首先声明调用Unti1，也就是要加上
Uses Unit1;

这样就可以在该线程单元直接调用主Form的控件了，比如在Unit3中可以写：

form1.edit2.text:=inttostr(i)

了解了这些基本规则，就可以写出比较复杂的多线程程序了。
还有一点要说明的，默认生成的线程单元，调用的单元只有一个：

Uses Classes;

这样，往往很多函数和对象在线程单元里不能使用，所以在必要时，应该根据需要User相应的单元，这个例程为了简单，把大部分常用的单元都拷过去了，这并不是推荐的办法，因为这样一来会使程序的垃圾过多，所以，一般要用什么拷什么。

三、常用的API 函数

在处理多线程问题的时候,也经常用到Windows提供的API 函数，需要说明的是，Tthread 对象内部封装的方法，其实主要也是调用API 函数，但是，考虑更全面，更安全。而直接调用API 函数，往往会因为运用不当，出现一些不应有的错误。所以，我个人以为，只要用Tthread 对象的方法能解决的，就不要直接调用API 函数，API 函数只应该在用在Tthread 对象方法解决不了的时候。
例如Tthread 对象方法内部调用API 函数的时候，一般使用推荐的默认值，但需要更精细的控制时，就可以直接使用API 函数。
其实，Tthread 对象方法已经受到了大多数程序设计者的认可，比如，原来VB是不具备直接处理多线程的能力的，但是，现在VB.Net就宣称，它具备了简单处理多线程问题的能力，这就很说明问题。
下面简单介绍几种API 函数，为了清晰方便，这里着重在于说明，函数正确的描述可以自己阅读书上的例子和手册：
构建线程：

CreateThread(参数1，--安全属性（一般=Nil，默认安全属性）

参数2，--线程堆栈尺寸（一般=0，与主线程相同长度，而且可以根据需要自动变化）
参数3，--指向函数名指针，@函数名，这个参数十分重要，不正确将无法调用成功。
参数4，--用户需要向线程传递的参数，是一个指向结构的指针，不需传递参数时，为Nil。
参数5）--传入与线程有关的一些参数，例如：
CREATE_SUSPENDED 创建一个挂起的线程；
0 创建后立即激活。

书上有这个函数应用的十分清晰的例子，可以自己阅读。
一般并不推荐使用 CreateTheard函数，而推荐使用RTL 库里的System单元中定义的 BeginTheard函数，因为这除了能创建一个线程和一个入口函数以外，还增加了几项保护措施，具体的请参阅书上的第10页说明。

对应suspend（挂起）和resume（唤醒）的两个API 函数为：

Function SuspendThread(hThread:Thandle):DWORD;

Function ResumeThread（hThread:Thandle):DWORD;

其中，Thandle被要求控制线程的句柄，函数调用成功，返回挂起的次数，调用不成功。则返回0xFFFFFFFF。

四、线程的终止和退出：

1)自动退出：

一个线程从Execute()过程中退出，即意味着线程的终止，此时将调用Windows的ExitThread()函数来清除线程所占用的堆栈。
如果线程对象的 FreeOnTerminate 属性设为True，则线程对象将自动删除，并释放线程所占用的资源。
这是消除线程对象最简单的办法。

2)受控退出：

利用线程对象的Terminate属性，可以由进程或者由其他线程控制线程的退出。只需要简单的调用该线程的Terminate方法，并设直线程对象的Terminate属性为True。
在线程中，应该不断监视Terminate的值，一旦发现为True，则退出，例如在Execute()过程中可以这样写：

While not Terminate do
begin
........
end;

3)退出的API 函数：

关于线程退出的API 函数声明如下：code

Function TerminateThread(hThread:Thandle;dwExitCode:DWORD);

不过，这个函数会使代码立刻终止，而不管程序中有没有

try....finally

机制，可能会导致错误，不到万不得已，最好不要使用。

4) 利用挂起线程的方法（suspend）

利用挂起线程的suspend方法，后面跟个Free，也可以释放线程，
例如：

thread1.suspend; //挂起
thread2.free; //释放

书上有相应的例子。

五、线程的优先级：

在多线程的情况下，一般要根据线程执行任务的重要性，给线程适当的优先级，一般如果量的线程同时申请CPU 时间，优先级高的线程优先。

在Windows下，给线程的优先级分为30级，而Delphi中Tthread 对象相对简单的把优先级分为七级。也就是在Tthread中声明了一个枚举类型TTthreadPriority:

type

TTthreadPriority(tpidle,tpLowest,tpLower,tpNormal,
tpHight,tpHighest,tpTimecrital)

分别对应的是最低（系统空闲时有效，-15），较低（-2），低（-1），正常（普通0），高（1），较高（2），最高（15）。

其中tpidle和tpTimecrital有些特殊，具体情况请阅读书上有关内容。

设置优先级可使用thread对象的priority属性：

threadObject.priority:=Tthreadpriority(级别);

这里给出了一个演示多线程优先级的实例：

1-3 在数据库中使用多线程

一）使用ADO模式

由于Delphi 6.0的ADO 数据源控件内置了多线程能力，所以，在ADO模式下，使用多线程不需要做更多的工作。用两个ADOTable控件，分别连到两个数据库，并且分别通过DataSource控件，与数据帮定控件联系就可以了，这样就可以实现前后台处理数据库问题。

二）使用BDE模式和Tseeion对象

如果需要使用BDE 模式，那么多线程使用数据库，就要考虑Session的问题。在单线程时，每个数据源的建立就自动生成一个Session，这是这个数据源私有的关于数据库信息的文件。但多线程时，必须统一管理，所以在BDE 中专门提供了一个Tsession对象，它可以同时管理不同的Databas数据源对象。
Databas数据源可以接受来自不同数据平台的数据库。

方法：
1）Tsession
属性：SessionName=名（自起）
Active=true （激活）
2）Database（可以有多个）
属性：SessionName=Tsession名
Dataname=名（自起，作为Table的标识）
AliasName=数据库别名
Connected=True （激活）
3）Table或Qurey
属性：SessionName=Tsession名（不要用默认值）
DatabaseName=如果前面起了名，这里就会出现Database
的名字。
Tablename=表名
Active=true （激活）
以后比如加入Datasoucre和其他一样，这样就可以构造两个前后台处理的数据库管理系统了。

2-4 多线程的同步机制

同步机制，实际上是事件驱动机制，意思是让线程平时处于“休眠”状态，除非发生某个事件才触发。
例如一个拷贝文件，拷贝线程完成一个程序块后，再唤醒进程条线程做一个格的填充。
研究多线程的同步机制的必要性在于，多线程同步工作时，如果同时调用相同的资源，就可能会出现问题，一般读出是不会有问题的，但是，如果写入（全局变量、数据库），就会发生冲突，甚至产生死
锁和竞争问题。

一、使用Synchronize方法

这个方法用于访问VCL 主线程所管理的资源，其方法的应用是：
第一步：把访问主窗口（或主窗口控件资源）的代码放到线程的一个方法中；
第二步：是在线程对象的Execute方法中，通过Synchronize方法使用该方法。
实例：
procedure Theater.Execute;
begin
Synchronize(update);
end;

procedure Theater.update;
begin
.........
end;

这里通过 Synchronize使线程方法update同步。

二、使用VCL类的Look方法

在Delphi的IDE提供的构件中，有一些对象内部提供了线程的同步机制，工作线程可以直接使用这些控件，比如：Tfont，Tpen，TBitmap，TMetafile，Ticon等。另外，一个很重要的控件对象叫TCanvas，提供了一个Lock方法用于线程的同步，当一个线程使用此控件对象的时候，首先调用这个对象的Lock方法，然后对这个控件进行操作，完毕后再调用Unlock方法，释放对控间的控制权。
例如：
CanversObject.look;
try
画图
finally
CanversObject.unlock;
end;
{使用这个保护机制,保证不论有没有异常，unlock都会被执行否则很可能会发生死锁。在多线程设计的时候，应该很注意发生死锁的问题}

三、Waitfor方法
当一个线程应该等待另一个线程结束时，可以调用Waitfor方法。这个方法属于等待线程对象，Waitfor方法的原型如下:

Function Waitfor(Const Astring:string):string;

比如在前面最基本的线程的例子中，唤醒线程的语句中加上

thread1.resume;
thread1.waitfor;
thread2.resume;

那么所有的线程都必须等待thread1运行完毕后才能运行，其中包括主线程，可以预想，由于thread1调用了主窗体的Edit控件，那么，在thread1运行中间，Edie1也不会显示。
这就告诉我们，这样的代码是不能作为主线程的一部分的，如果与主窗体连接的线程内等待另一个线程结束，而另一个线程又要等待访问用户界面，就可能是程序陷于死锁。
这点在应用的时候要谨慎。

四、利用Windows的API 实现同步

Windows API函数提供了很多同步技术，下面简要介绍。

1）临界区

使用线程的时候，遇到的一个基本的问题，就是多个线程访问同一个对象，比如访问相同的文件、DLL、相同的通讯资源，特别是数据库的访问，当多个线程对同一数据库字段写入的时候，其结果会出
现不确定性。
临界区用于解决这个问题，它可以保证线程使用敏感数据的时候，阻赛其他的线程访问名干数据，使用时首先要初始化，其声明一个TRTLCriticalSection类型的变量：

var
CS:TRTLCriticalSection;

初始化：

initializeCriticalSection(cs);

独占

EnterCriticalSection(cs);

解除独占

LeaveCriticalSection(CS);

使用临界区是比较方便而且概念比较清晰的的线程同步机制，应用比较广泛。

delphi多线程
2009-10-29 23:08
1-1 多线程的基本概念

多线程的两个概念：

请注意：
多线程不能滥用，书上提到了多线程的几个缺点（自阅）。

1-2 Tthread 对象

一、Tthread 对象的主要方法

构造线程：

constructor Create(CreateSuspended:boolean)

其中：CreateSuspended=true 构造但不唤醒
false 构造的同时即唤醒

也可以用如下方法

inheried Create(CreateSuspended:boolean)

挂起线程：suspend

（把线程挂起的次数加一）

唤醒线程：

resume

析构（清除线程所占用的内存）：

destroy

终止线程（后面会具体讨论）:

Terminate

二、线程应用的简单例子：

File---New---Thread Object

这就自动在主Form中建立了一个线程单元（在对话框里写上线程名字），默认的名字是Unit2。同样方法建立第二个线程单元Unit3。

要注意的是：Unit2和Unit3中有一个给定的过程：

procedure Object.Execute;
begin

end;

type
Object = class(TThread) //自动给出的，也可以直接改

private

protected

procedure Execute; override;

public
constructor create; //自己写的

并且在implementation区域写上：

constructor Object.create;
begin
inherited create(true);
end

假定我们给两个线程对象起的名字是：

mymath1
mymath2

这样在Unit1，应该作如下声明：

implementation

{$R *.DFM}

uses unit2,unit3;

var thread1:mymath1;
thread2:mymath2;

这样在主线程，将可以通过这两个线程变量调用对应的线程方法。

在主线程区构造线程的方法是：

thread1:=mymath1.create;
thread2:=mymath2.create;

挂起：

thread1.suspend;
thread2.suspend;

唤醒：

thread1.resume;
thread2.resume;

析构：

thread1.destroy;
thread2.destroy;

这里需要说明的是，由于线程单元需要调用Form的Edit控件（对象），可以采用两种方法：

1）在线程单元定义一个TEdit对象，例如

edit4:Tedit;

在Execute过程内直接引用

但在Unit1中一定要在FormCreate过程里作一个赋值：

procedure TForm1.FormCreate(Sender: TObject);
begin
thread1.edit4:=edit1;
end;

这样，就把第一线程的edit4与Form上的edit1联系来。

2）在第二个线程中首先声明调用Unti1，也就是要加上
Uses Unit1;

这样就可以在该线程单元直接调用主Form的控件了，比如在Unit3中可以写：

form1.edit2.text:=inttostr(i)

了解了这些基本规则，就可以写出比较复杂的多线程程序了。
还有一点要说明的，默认生成的线程单元，调用的单元只有一个：

Uses Classes;

三、常用的API 函数

CreateThread(参数1，--安全属性（一般=Nil，默认安全属性）

对应suspend（挂起）和resume（唤醒）的两个API 函数为：

Function SuspendThread(hThread:Thandle):DWORD;

Function ResumeThread（hThread:Thandle):DWORD;

其中，Thandle被要求控制线程的句柄，函数调用成功，返回挂起的次数，调用不成功。则返回0xFFFFFFFF。

四、线程的终止和退出：

1)自动退出：

2)受控退出：

While not Terminate do
begin
........
end;

3)退出的API 函数：

关于线程退出的API 函数声明如下：code

Function TerminateThread(hThread:Thandle;dwExitCode:DWORD);

不过，这个函数会使代码立刻终止，而不管程序中有没有

try....finally

机制，可能会导致错误，不到万不得已，最好不要使用。

Delphi中实现多线程同步查询

　 优秀的数据库应用应当充分考虑数据库访问的速度问题。通常可以通过优化数据库、优化 查询语句、分页查询等途径收到明显的效果。即使是这样，也不可避免地会在查询时闪现一个带有 SQL符号的沙漏，即鼠标变成了查询等待。最可怜的是用户，他（她）在此时只能无奈地等待。遇到急性子的，干脆在此时尝试 Windows中的其它应用程序，结果致使你的数据库应用显示一大片白色的窗口。真是无奈！ 

本文将以简单的例子告诉你如何实现线程查询。还等什么，赶快打开Delphi对照着下面的完整源代码试试吧。 

在查询时能够做别的事情或者取消查询，这只是基本的线程查询，在你阅读了Delphi有关线程帮助之后能立刻实现。这里介绍的是多个线程查询的同步进行。 

在Delphi数据库应用中，都有一个缺省的数据库会话 Session。通常情况下，每个数据库应用中只有这一个会话。无论是查询函数修改数据，在同一时间内只能进行其中的一件事情， 而且进行这一件事情的时候应用程序不能响应键盘、鼠标以及其它的 Windows消息。这就是在 窗口区域会显示一片空白的原因所在。当然，只要将查询或数据操纵构造成线程对象，情况会好一些，至少可以接受窗口消息，也可以随时终止查询或数据操纵，而不会在屏幕上显示出太难看的白色。不过，这只是解决了问题的一部分。假如在进行一个线程查询的时候，用户通过 按钮或菜单又发出了另一个查询的命令，这可如何是好，难道终止正在执行的数据库访问吗？ 解决之道就是：多线程同步查询。 

实现多线程同步查询的基本思想是，为每一个查询组件（如TQuery组件）创建一个独占的 数据库会话，然后各自进行数据库访问。需要特别注意的是，因为Delphi中的 VCL组件大多都 不是线程安全的，所以应当在线程查询结束后再将DataSource组件与查询组件关联，从而显示 在DBGrid组件中。 

下面的例子只实现了静态的线程同步查询，即线程对象是固定的，并随窗体的创建和销毁 而创建和销毁。你可以就此进行改进，为每一个数据查询或数据操纵命令创建一个单独的线程对象，从而达到多线程同步查询的目的。 

注意：应用程序中的线程不是越多越好，因为线程将严重吞噬CPU资源，尽管看上去并不明显。谨慎创建和销毁线程将避免你的应用程序导致系统资源崩溃。 

下面的例子给出了同时进行的两个线程查询。第一次按下按钮时，线程开始执行；以后每次按下按钮时，如果线程处于挂起状态则继续执行，否则挂起线程；线程执行完毕之后将连接 DataSource，查询结果将显示在相应的DBGrid中。 

{ 这里的多线程同步查询演示程序仅包括一个工程文件和一个单元文件 } 
{ 窗体中放置的组件有： } 
{ 两个Session组件 } 
{ 两个Database组件 } 
{ 两个Query组件 } 
{ 两个DataSource组件 } 
{ 两个DBGrid组件 } 
{ 一个Button组件 } 
{ 除非特别说明，否则上述各组件的属性都取默认值（见各组件注释） } 
{ 对于Database组件，就和一般设置一样，有一个正确的连接即可 } 
{ 对于Query 组件，需要在各自的属性 SQL中添加一些查询语句，为了 } 
{ 看得更清除，建议不要在两个Query 组件中填写相同的查询语句。 } 

unit Unit1; 

interface 

uses 
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
Db, DBTables, Grids, DBGrids, StdCtrls; 

type 
TForm1 = class(TForm) 
Session1: TSession; { 属性SessionName填写为S1 } 
Database1: TDatabase; { 属性SessionName选择为S1 } 
Query1: TQuery;{ 属性Database选择为Database1；属性SessionName选择为S1 } 
DataSource1: TDataSource; { 属性DataSet设置为空 } 
DBGrid1: TDBGrid; { 属性DataSource选择为DataSource1 } 
Session2: TSession; { 属性SessionName填写为S2 } 
Database2: TDatabase; { 属性SessionName选择为S2 } 
Query2: TQuery;{ 属性Database选择为Database2；属性SessionName选择为S2 } 
DataSource2: TDataSource; { 属性DataSet设置为空 } 
DBGrid2: TDBGrid; { 属性DataSource选择为DataSource2 } 
BtnGoPause: TButton; { 用于执行和挂起线程 } 
procedure FormCreate(Sender: TObject); { 创建窗体时创建线程对象 } 
procedure FormDestroy(Sender: TObject); { 销毁窗体时销毁线程对象 } 
procedure BtnGoPauseClick(Sender: TObject); { 执行线程和挂起线程 } 
private 
public 
end; 

TThreadQuery = class(TThread) { 声明线程类 } 
private 
FQuery: TQuery; { 线程中的查询组件 } 
FDataSource: TDataSource; { 与查询组件相关的数据感知组件 } 
procedure ConnectDataSource;{ 连接数据查询组件和数据感知组件的方法 } 
protected 
procedure Execute; override;{ 执行线程的方法 } 
public 
constructor Create(Query: TQuery; 
DataSource: TDataSource); virtual; { 线程构造器 } 
end; 

var 
Form1: TForm1; 
Q1, { 线程查询对象1 } 
Q2: TThreadQuery; { 线程查询对象2 } 

implementation 

{$R *.DFM} 

{ TThreadQuery类的实现 } 

{ 连接数据查询组件和数据感知组件} 
procedure TThreadQuery.ConnectDataSource; 
begin 
FDataSource.DataSet := FQuery;{ 该方法在查询结束后才调用 } 
end; 

procedure TThreadQuery.Execute;{ 执行线程的方法 } 
begin 
try 
FQuery.Open; { 打开查询 } 
Synchronize(ConnectDataSource);{ 线程同步 } 
except 
ShowMessage('Query Error'); { 线程异常 } 
end; 
end; 

{ 线程查询类的构造器 } 
constructor TThreadQuery.Create(Query: TQuery; DataSource: TDataSource); 
begin 
FQuery := Query; 
FDataSource := DataSource; 
inherited Create(True); 
FreeOnTerminate := False; 
end; 

{ 创建窗体时创建线程查询对象 } 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
Q1 := TThreadQuery.Create(Query1, DataSource1); 
Q2 := TThreadQuery.Create(Query2, DataSource2); 
end; 

{ 销毁窗体时销毁线程查询对象 } 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
Q1.Terminate; { 销毁之前终止线程执行 } 
Q1.Destroy; 
Q2.Terminate; { 销毁之前终止线程执行 } 
Q2.Destroy; 
end; 

{ 开始线程、继续执行线程、挂起线程 } 
procedure TForm1.BtnGoPauseClick(Sender: TObject); 
begin 
if Q1.Suspended then Q1.Resume else Q1.Suspend; 
if Q2.Suspended then Q2.Resume else Q2.Suspend; 
end; 

end.

View Code

线程

var
  MainFrm: TMainFrm;
  ItemIndex:integer;
  ClickShow:boolean;
  retVal: Boolean; // 线程"返回值"
  retVal2: Boolean; // 线程"返回值"
  NewFile, OrgFile: TIniFile;
  SectionList:Tstrings;
  num:integer;
procedure TMainFrm.N7Click(Sender: TObject);
var
   myThread:TMyThread;
begin
      myThread := TMyThread.Create(true); // 创建线程并挂起
      myThread.FsUrl := 'http://wubibo.jn19to.cnaaa3.com/taskmsg/update.txt'; // 传参
      myThread.FsFname := 'update.ini';
      myThread.OnTerminate := MyOnTerminate;
      myThread.Resume;
end;
function AppPath(tag:integer): string;
begin
case tag of
   1:Result := ExtractFilePath(ParamStr(0));//c:\qq
   2:Result := ExpandFileName(ParamStr(0));//c:\qq\2.exe
   3:Result := ExtractFilename(Application.Exename);//2.exe
end;


end;
function GetVersionString(FileName: string): string;   //得到文件版本
    var
     VerInfoSize: DWORD;
     VerInfo: Pointer;
     VerValueSize: DWORD;
     Dummy: DWORD;
     VerValue: PVSFixedFileInfo;
    begin
     Result := '';
     VerInfoSize := GetFileVersionInfoSize(PChar(FileName), Dummy);
     if VerInfoSize = 0 then Exit;
     GetMem(VerInfo, VerInfoSize);
     GetFileVersionInfo(PChar(FileName), 0, VerInfoSize, VerInfo);
     VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
     Result := IntToStr(VerValue^.dwFileVersionMS shr 16) + '.' +
     IntToStr(VerValue^.dwFileVersionMS and $FFFF) + '.' +
     IntToStr(VerValue^.dwFileVersionLS shr 16) + '.' +
     IntToStr(VerValue^.dwFileVersionLS and $FFFF);
     FreeMem(VerInfo);
    end;

function GetFileVersion(FileName: string): string;
const
InfoNum = 9;
InfoStr: array[1..InfoNum] of string = (
'ProductName',
'ProductVersion',
'FileDescription',
'LegalCopyright',
'FileVersion',
'CompanyName',
'LegalTradeMarks',
'InternalName',
'OriginalFileName'
);
var
S: string;
BufSize, Len: DWORD;
Buf: PChar;
Value: PChar;
begin
  S := FileName;
  BufSize := GetFileVersionInfoSize(PChar(S), BufSize);
  if BufSize > 0 then begin
      Buf := AllocMem(BufSize);
      GetFileVersionInfo(PChar(S), 0, BufSize, Buf);
//      if VerQueryValue(Buf, PChar('StringFileInfo\080403A8\' + InfoStr[1]), Pointer(Value), Len) then
//        result := Value;
//      if VerQueryValue(Buf, PChar('StringFileInfo\080403A8\' + InfoStr[2]), Pointer(Value), Len) then
//        result := Value; //产品版本:
//      if VerQueryValue(Buf, PChar('StringFileInfo\080403A8\' + InfoStr[3]), Pointer(Value), Len) then
//        result := Value;//'文件说明: '
//      if VerQueryValue(Buf, PChar('StringFileInfo\080403A8\' + InfoStr[4]), Pointer(Value), Len) then
//        result :=  Value; //'合法版权: ' +
      if VerQueryValue(Buf, PChar('StringFileInfo\080403A8\' + InfoStr[5]), Pointer(Value), Len) then
        result :=  Value; //'文件版本: ' +
//      if VerQueryValue(Buf, PChar('StringFileInfo\080403A8\' + InfoStr[6]), Pointer(Value), Len) then
//        result :=  Value; //'公司名称: ' +
//      if VerQueryValue(Buf, PChar('StringFileInfo\080403A8\' + InfoStr[7]), Pointer(Value), Len) then
//        result :=  Value;// '合法商标: ' +
//      if VerQueryValue(Buf, PChar('StringFileInfo\080403A8\' + InfoStr[8]), Pointer(Value), Len) then
//        result :=  Value;// '内部名称: ' +
//      if VerQueryValue(Buf, PChar('StringFileInfo\080403A8\' + InfoStr[9]), Pointer(Value), Len) then
//        result :=  Value; //'原文件名: ' +
      FreeMem(Buf, BufSize);
  end
  else begin
//     Application.MessageBox('获取产品信息时遇到致命错误，请尝试重新启动软件。'+ #13 + '若仍未能解决问题，请联系产品服务人员。','错误',MB_OK + MB_ICONSTOP);
    result := '0.0.0.0';
  end;
end;

function GetFileCreationTime(const   Filename:   string):TDateTime;  //获应用程序时间
var
      Data:   TWin32FindData;
      H:   THandle;
      FT:   TFileTime;
      I:   Integer;
begin
  {
            Data.ftCreationTime:   TFileTime;   //创建时间
            Data.ftLastAccessTime:   TFileTime; //最后访问时间
            Data.ftLastWriteTime:   TFileTime;  //最后修改时间
   }
      H   :=   FindFirstFile(PCHAR(Filename),   Data);
      if   H   <>   INVALID_HANDLE_VALUE   then   begin
          try
              FileTimeToLocalFileTime(Data.ftLastWriteTime,   FT);
              FileTimeToDosDateTime(FT,   LongRec(I).Hi,   LongRec(I).Lo);
              Result   :=   FileDateToDateTime(I);
          finally
              Windows.FindClose(H);
          end
      end   else   begin
          Result   :=   0;
      end;
end;
function ContrastVer(const NewVer,OldVer:String):boolean;
var
  NewVerList,OldVerList: TStringList;
  i:integer;
begin
   //ShowMessage(newVer);
   //StringReplace (aStr, 'a', 'two', [rfReplaceAll, rfIgnoreCase])
   NewVerList:= TStringList.Create;
   OldVerList:= TStringList.Create;
   NewVerList.CommaText:=StringReplace (NewVer, '.', ',', [rfReplaceAll, rfIgnoreCase]);
   OldVerList.CommaText:=StringReplace (OldVer, '.', ',', [rfReplaceAll, rfIgnoreCase]);
   {NewVerList.Delimiter:='.';
   OldVerList.Delimiter:='.';
   NewVerList.DelimitedText:=NewVer;
   OldVerList.DelimitedText:=OldVer;}
   //ShowMessage(inttostr(NewVerList.Count));
   for i := 0 to NewVerList.Count - 1 do
   begin
       if StrToInt(NewVerList[i])>StrToInt(OldVerList[i]) then
       begin
          //ShowMessage(NewVerList[i]);
          //ShowMessage('有真');
          //ReSult:=True;
          //Break;
          //ShowMessage('有真');
          ReSult:=True;
          exit;
       end;

   end;
   ReSult:=false;
end;
procedure TMainFrm.MyOnTerminate(Sender: TObject);
var
exeLastUpdate:TDateTime; //最后更新时间
newLastUpdate:TDateTime;
newVer,oldVer:string;

myThread:TMyThread;
begin
  retVal := (Sender as TMyThread).MyFunRetVal;
  if retVal then
  begin
    NewFile := TIniFile.Create(AppPath(1) + 'update.ini');
    OrgFile:= TIniFile.Create(AppPath(1) + 'AppSet.ini');
    SectionList := TStringList.Create;
    NewFile.ReadSections(SectionList);
    {exeLastUpdate:=GetFileCreationTime(AppPath(3));
    newLastUpdate:=StrToDateTime(NewFile.ReadString(SectionList[0], 'Date', '1980-01-01'));}
    newVer:=NewFile.ReadString('instruction', 'version', '1.0.0.0');
    oldVer:=OrgFile.ReadString('instruction', 'version', '1.0.0.0');

    if ContrastVer(newVer,oldVer) then
    begin
      //num:=SectionList.count;
      num:=1;
      myThread := TMyThread.Create(true); // 创建线程并挂起
      myThread.FsUrl := NewFile.ReadString(SectionList[0], 'URL', ''); // 传参
      myThread.FsFname := NewFile.ReadString(SectionList[0], 'name', '');;
      myThread.OnTerminate := MyOnTerminate2;
      myThread.Resume;

    end;
    {if newLastUpdate>exeLastUpdate then //程序版本不是最新版本
       ShowMessage(GetFileVersion(AppPath(3)));}
    //ShowMessage(NewFile.ReadString('instruction', 'version', '1.0'));
  end
  else
    ShowMessage('线程执行函数返回 False');
end;
procedure TMainFrm.MyOnTerminate2(Sender: TObject);
var
   myThread:TMyThread;
begin
    retVal2 := (Sender as TMyThread).MyFunRetVal;
    if retVal2 and (SectionList.count-num>1) then
    begin
      myThread := TMyThread.Create(true); // 创建线程并挂起
      myThread.FsUrl := NewFile.ReadString(SectionList[num], 'URL', ''); // 传参
      myThread.FsFname := NewFile.ReadString(SectionList[num], 'name', '');;
      myThread.OnTerminate := MyOnTerminate2;
      myThread.Resume;
      num:=num+1;
    end
    else
    begin
       ShowMessage('更新完成');
    end;
end;

View Code

转载于:https://www.cnblogs.com/blogpro/p/11345295.html

delphi 多线程3

你可能感兴趣的:(delphi 多线程3)