ThreadedTimer 如题线程定时器

 
//////////////////////////////////////////////////// 
//                                                // 
//   ThreadedTimer 1.2a                           // 
//                                                // 
//   Copyright (C) 1996, 2000 Carlos Barbosa      // 
//   email: delphi@carlosb.com                    // 
//   Home Page: http://www.carlosb.com            // 
//                                                // 
//   Portions (C) 2000, Andrew N. Driazgov        // 
//   email: andrey@asp.tstu.ru                    // 
//                                                // 
//   Last updated: November 24, 2000              // 
//                                                // 
//////////////////////////////////////////////////// 
 
unit ThdTimer; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; 
 
const 
  DEFAULT_INTERVAL = 1000; 
 
type 
  TThreadedTimer = class; 
 
  TTimerThread = class(TThread) 
  private 
    FOwner: TThreadedTimer; 
    FInterval: Cardinal; 
    FStop: THandle; 
  protected 
    procedure Execute; override; 
  end; 
 
  TThreadedTimer = class(TComponent) 
  private 
    FOnTimer: TNotifyEvent; 
    FTimerThread: TTimerThread; 
    FEnabled: Boolean; 
 
    procedure DoTimer; 
 
    procedure SetEnabled(Value: Boolean); 
    function GetInterval: Cardinal; 
    procedure SetInterval(Value: Cardinal); 
    function GetThreadPriority: TThreadPriority; 
    procedure SetThreadPriority(Value: TThreadPriority); 
  public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
 
  published 
    property Enabled: Boolean read FEnabled write SetEnabled default False; 
    property Interval: Cardinal read GetInterval write SetInterval default DEFAULT_INTERVAL; 
    property OnTimer: TNotifyEvent read FOnTimer write FOnTimer; 
    property ThreadPriority: TThreadPriority read GetThreadPriority  write SetThreadPriority default tpNormal; 
  end; 
 
procedure Register; 
 
implementation 
 
{ TTimerThread } 
 
procedure TTimerThread.Execute; 
begin 
  repeat 
    if WaitForSingleObject(FStop, FInterval) = WAIT_TIMEOUT then 
      Synchronize(FOwner.DoTimer); 
  until Terminated; 
end; 
 
{ TThreadedTimer } 
 
constructor TThreadedTimer.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  FTimerThread := TTimerThread.Create(True); 
  with FTimerThread do 
  begin 
    FOwner := Self; 
    FInterval := DEFAULT_INTERVAL; 
    Priority := tpNormal; 
 
    // Event is completely manipulated by TThreadedTimer object 
    FStop := CreateEvent(nil, False, False, nil); 
  end; 
end; 
 
destructor TThreadedTimer.Destroy; 
begin 
  with FTimerThread do 
  begin 
    Terminate; 
 
    // When this method is called we must be confident that the event handle was not closed 
    SetEvent(FStop); 
    if Suspended then 
      Resume; 
    WaitFor; 
    CloseHandle(FStop);  // Close event handle in the primary thread 
    Free; 
  end; 
  inherited Destroy; 
end; 
 
procedure TThreadedTimer.DoTimer; 
begin 
 
  // We have to check FEnabled in the primary thread 
  // Otherwise we get AV when the program is closed 
  if FEnabled and Assigned(FOnTimer) then 
    FOnTimer(Self); 
end; 
 
procedure TThreadedTimer.SetEnabled(Value: Boolean); 
begin 
  if Value <> FEnabled then 
  begin 
    FEnabled := Value; 
    if FEnabled then 
    begin 
      if FTimerThread.FInterval > 0 then 
      begin 
        SetEvent(FTimerThread.FStop); 
        FTimerThread.Resume; 
      end; 
    end 
    else 
      FTimerThread.Suspend; 
  end; 
end; 
 
function TThreadedTimer.GetInterval: Cardinal; 
begin 
  Result := FTimerThread.FInterval; 
end; 
 
procedure TThreadedTimer.SetInterval(Value: Cardinal); 
var 
  PrevEnabled: Boolean; 
begin 
  if Value <> FTimerThread.FInterval then 
  begin 
 
    // We must restore the previous state of the Enabled property 
    PrevEnabled := FEnabled; 
    Enabled := False; 
    FTimerThread.FInterval := Value; 
    Enabled := PrevEnabled; 
  end; 
end; 
 
function TThreadedTimer.GetThreadPriority: TThreadPriority; 
begin 
  Result := FTimerThread.Priority; 
end; 
 
procedure TThreadedTimer.SetThreadPriority(Value: TThreadPriority); 
begin 
  FTimerThread.Priority := Value; 
end; 
 
procedure Register; 
begin 
   RegisterComponents('System', [TThreadedTimer]); 
end; 
 
end.

View Code

unit thdTimer; 
 
interface 
 
uses 
Windows, Messages, SysUtils, Classes, 
Graphics, Controls, Forms, Dialogs; 
 
type 
TTimerStatus = (TS_ENABLE, TS_CHANGEINTERVAL, TS_DISABLE, TS_SETONTIMER); 
TThreadedTimer = class; 
TTimerThread = class; 
PTimerThread = ^TTimerThread; 
 
TTimerThread = class(TThread) 
    OwnerTimer: TThreadedTimer; 
    Interval: DWord; 
    Enabled : Boolean; 
    Status : TTimerStatus; 
    constructor Create(CreateSuspended: Boolean); 
    procedure Execute; override; 
    destructor Destroy; override; 
    procedure DoTimer; 
end; 
 
TThreadedTimer = class(TComponent) 
private 
    FEnabled: Boolean; 
    FInterval: DWord; 
    FOnTimer: TNotifyEvent; 
    FTimerThread: TTimerThread; 
    FThreadPriority: TThreadPriority; 
protected 
    procedure UpdateTimer; 
    procedure SetEnabled(Value: Boolean); 
    procedure SetInterval(Value: DWord); 
    procedure SetOnTimer(Value: TNotifyEvent); 
    procedure Timer; dynamic; 
public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
published 
    property Enabled: Boolean read FEnabled write SetEnabled default True; 
    property Interval: DWord read FInterval write SetInterval default 1000; 
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer; 
end; 
 
implementation 
uses Unit1; 
 
procedure WakeupDownThrdproc(const evenFlag: Integer); stdcall; 
begin 
  Form1.lbl1.Caption:=Format('鼠标键盘已经有   %d   秒没有使用',   [(LastInput)div   1000]); 
end; 
 
procedure TTimerThread.Execute; 
begin 
   inherited; 
   while not Terminated do 
   begin 
      SleepEx(Interval, True); 
      if (not Terminated) and (Status = TS_ENABLE) then Synchronize(DoTimer); 
      if Status <> TS_ENABLE then 
      begin 
          case Status of 
          TS_CHANGEINTERVAL: 
          begin 
              Status := TS_ENABLE; 
              SleepEx(0,True); 
          end; 
          TS_DISABLE: 
          begin 
              Status := TS_ENABLE; 
              SleepEx(0, True); 
              if not Terminated then Suspend; 
          end; 
          TS_SETONTIMER: 
          begin 
              Status := TS_ENABLE; 
          end 
          else Status := TS_ENABLE; 
          end; 
      end; 
   end; 
 
end; 
 
procedure TTimerThread.DoTimer; 
begin 
   OwnerTimer.Timer; 
end; 
 
constructor TThreadedTimer.Create(AOwner: TComponent); 
begin 
 
inherited Create(AOwner); 
FInterval := 1000; 
FThreadPriority := tpNormal; 
FTimerThread := TTimerThread.Create(true); 
FTimerThread.OwnerTimer := self; 
 
end; 
 
destructor TThreadedTimer.Destroy; 
begin 
inherited Destroy; 
FTimerThread.Terminate; 
QueueUserAPC(@WakeupDownThrdproc, FTimerThread.Handle, DWORD(FTimerThread)); 
FTimerThread.Free; 
end; 
 
procedure TThreadedTimer.UpdateTimer; 
begin 
 
   if (FEnabled = False) then 
   begin 
       FTimerThread.OwnerTimer := Self; 
       FTimerThread.Interval := FInterval; 
       FTimerThread.Priority := FThreadPriority; 
       FTimerThread.Resume; 
   end; 
   if (FEnabled = True) then 
   begin 
       QueueUserAPC(@WakeupDownThrdproc, FTimerThread.Handle, DWORD(FTimerThread)); 
   end; 
 
end; 
 
procedure TThreadedTimer.SetEnabled(Value: Boolean); 
begin 
 
   if Value <> FEnabled then 
   begin 
       FEnabled := Value; 
       if Value then 
       begin 
           FTimerThread.Status := TS_ENABLE; 
           FTimerThread.Resume; 
       end 
       else 
       begin 
           FTimerThread.Status := TS_DISABLE; 
           QueueUserAPC(@WakeupDownThrdproc, FTimerThread.Handle, DWORD(FTimerThread)); 
       end; 
   end; 
 
end; 
 
procedure TThreadedTimer.SetInterval(Value: DWord); 
begin 
   if Value <> FInterval then 
   begin 
      if (not Enabled) then 
      begin 
          FInterval := Value; 
          FTimerThread.Interval := FInterval; 
      end 
      else 
      begin 
          FInterval := Value; 
          FTimerThread.Interval := FInterval; 
          FTimerThread.Status := TS_CHANGEINTERVAL; 
          QueueUserAPC(@WakeupDownThrdproc, FTimerThread.Handle, DWORD(FTimerThread)); 
      end; 
   end; 
end; 
 
procedure TThreadedTimer.SetOnTimer(Value: TNotifyEvent); 
begin 
 
    FOnTimer := Value; 
end; 
 
procedure TThreadedTimer.Timer; 
begin 
   if Assigned(FOnTimer) then 
      FOnTimer(Self); //在这里放置的代码,是不是也属于多线程机制 
end; 
 
destructor TTimerThread.Destroy; 
begin 
    inherited; 
end; 
 
constructor TTimerThread.Create(CreateSuspended: Boolean); 
begin 
    inherited Create(CreateSuspended); 
    Interval := 1000; 
    Enabled := False; 
    Status := TS_DISABLE; 
end; 
 
end.

View Code

unit Unit1; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls, SvcMgr; 
 
const 
  WM_MyMessage = WM_USER + 100; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Memo1: TMemo; 
    Button2: TButton; 
    Button3: TButton; 
    procedure Button1Click(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
    procedure FormClose(Sender: TObject; var Action: TCloseAction); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
  end; 
 
  TMsgThread = class(TThread) 
  private 
    Atom1: atom; 
    FMyString: string; 
    procedure ShowString; 
  public 
    constructor Create(CreateSuspended: Boolean); overload; 
    destructor Destroy; override; 
    procedure ProcessRequests(WaitForMessage: Boolean); 
  protected 
    procedure Execute; override; 
  end; 
 
  //http://topic.csdn.net/t/20030218/17/1440830.html 在线程中怎样处理消息 
  //can zhao SvcMgr.pas zhong de TServiceThread 
  //另类远程线程插入法 http://www.blogcn.com/user17/fmtwld/blog/4441223.html 
  TMsgThread2 = class(TThread) 
  private 
    atomF4: atom; 
    CanTerminated: Boolean; 
    FMyString: string; 
    procedure ShowString; 
    procedure NotificationWndProc(var Message: TMessage); 
  public 
    MHandle: HWnd; 
    constructor Create(CreateSuspended: Boolean); overload; 
    destructor Destroy; override; 
  protected 
    procedure Execute; override; 
  end; 
 
var 
  Form1: TForm1; 
  TestThread: TMsgThread; 
  TestThread2: TMsgThread2; 
 
implementation 
 
{$R *.dfm} 
 
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); 
begin 
  PostMessage(TestThread2.MHandle, WM_CLOSE, 0, 0); 
  sleep(300); 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if assigned(TestThread) then 
    PostThreadMessage(TestThread.ThreadID, WM_QUIT, 0, 0); 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  if assigned(TestThread) then 
    PostThreadMessage(TestThread.ThreadID, WM_MyMessage, 0, 0); 
end; 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  if assigned(TestThread2) then 
    PostMessage(TestThread2.MHandle, WM_CLOSE, 0, 0); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  TestThread := TMsgThread.Create(False); 
  TestThread2 := TMsgThread2.Create(False); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  if assigned(TestThread) then 
  begin 
    TestThread.Terminate; 
    if TestThread.Suspended then 
      TestThread.Suspend; 
    TestThread.WaitFor; 
    FreeAndNil(TestThread); 
  end; 
 
  if assigned(TestThread2) then 
  begin 
    TestThread2.Terminate; 
    if TestThread2.Suspended then 
      TestThread2.Suspend; 
    TestThread2.WaitFor; 
    FreeAndNil(TestThread2); 
  end; 
end; 
 
{ TMsgThread } 
 
constructor TMsgThread.Create(CreateSuspended: Boolean); 
begin 
 
  inherited Create(CreateSuspended); 
end; 
 
destructor TMsgThread.Destroy; 
begin 
 
  inherited; 
end; 
 
procedure TMsgThread.Execute; 
var 
  msg: TMsg; 
begin 
  Atom1:=globalfindatom('HotKeyIDhzh'); 
  if Atom1=0 then 
    Atom1 := GlobalAddAtom('HotKeyIDhzh'); 
  RegisterHotKey(0, Atom1, MOD_CONTROL, ord('B')); 
  //RegisterHotKey(Handle, atomF4, 0, vk_F4); 
   
  FMyString := 'Thread Started!'; 
  Synchronize(ShowString); 
  PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE); { Create message queue } 
  //ProcessRequests(True); 
  ProcessRequests(False); 
   
  UnRegisterHotKey(0, Atom1); //取消热键 
  GlobalDeleteAtom(Atom1); 
end; 
 
{procedure TMsgThread.Execute; 
var 
  Msg: TMsg; 
  DMsg: TMessage; 
begin 
  FMyString := 'Thread Started!'; 
  Synchronize(ShowString); 
  while (not Terminated) do 
  begin 
    if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then 
    begin 
      if (Msg.message = WM_QUIT) then 
      begin 
        FMyString := 'Thread QuIT'; 
        Synchronize(ShowString); 
        Terminate; 
      end; 
      if (Msg.message = WM_MyMessage) then 
      begin 
        FMyString := 'Thread  Get a USER Message!'; 
        Synchronize(ShowString); 
      end; 
      if (Msg.message = WM_HOTKEY) then 
      begin 
        DMsg.Msg    := Msg.message; 
        DMsg.wParam := Msg.wParam; 
        DMsg.lParam := Msg.lParam; 
        DMsg.Result := 0; 
        //if (DMsg.LParamLo = MOD_CONTROL) and (DMsg.LParamHi = ord('B')) then 
        begin 
          FMyString := 'TMsgThread Get Ctrl R!'; 
          Synchronize(ShowString); 
        end; 
      end; 
    end; 
  end; 
end;} 
 
procedure TMsgThread.ProcessRequests(WaitForMessage: Boolean); 
var 
  msg: TMsg; 
  DMsg: TMessage; 
  Rslt: Boolean; 
begin 
  while not Terminated do 
  begin 
    //FillChar(msg, sizeof(msg), #0); 
    if WaitForMessage then 
      Rslt := GetMessage(msg, 0, 0, 0) 
    else 
      Rslt := PeekMessage(msg, 0, 0, 0, PM_REMOVE); 
    if not Rslt then // Some Meesage will PM_REMOVE Fail 
    begin 
      //FMyString := 'PeekMessage none!'; 
      //Synchronize(ShowString); 
      //break; 
      continue; 
    end; 
    if Rslt and (msg.hwnd = 0) then { Thread message } 
    begin 
      if (Msg.message = WM_QUIT) then 
      begin 
        FMyString := 'Thread QuIT'; 
        Synchronize(ShowString); 
        Terminate; 
      end 
      else 
      if (Msg.message = WM_MyMessage) then 
      begin 
        FMyString := 'Thread  Get a USER Message!'; 
        Synchronize(ShowString); 
      end 
      else 
      if (Msg.message = WM_HOTKEY) then 
      begin 
        DMsg.Msg    := Msg.message; 
        DMsg.wParam := Msg.wParam; 
        DMsg.lParam := Msg.lParam; 
        DMsg.Result := 0; 
        if (DMsg.LParamLo = MOD_CONTROL) and (DMsg.LParamHi = ord('B')) then 
        begin 
          FMyString := 'TMsgThread Get Ctrl B!'; 
          Synchronize(ShowString); 
        end; 
      end 
      else 
        DispatchMessage(msg); 
    end else 
      DispatchMessage(msg); 
  end; 
end; 
 
procedure TMsgThread.ShowString; 
begin 
  Form1.Memo1.Lines.Add(FMyString); 
end; 
 
{ TMsgThread2 } 
 
constructor TMsgThread2.Create(CreateSuspended: Boolean); 
begin 
  CanTerminated := False; 
  MHandle := Classes.AllocateHWnd(NotificationWndProc); 
  atomF4 := GlobalAddAtom('hot_key2'); 
  //RegisterHotKey(Mhandle, atomF4, 0, vk_F4); 
  RegisterHotKey(Mhandle, atomF4, MOD_CONTROL, ord('R')); 
  inherited Create(CreateSuspended); 
end; 
 
destructor TMsgThread2.Destroy; 
begin 
  UnRegisterHotKey(Mhandle, atomF4); //取消热键 
  GlobalDeleteAtom(atomF4); //释放id 
  if MHandle <> 0 then 
    Classes.DeallocateHWnd(MHandle); 
  inherited; 
end; 
 
procedure TMsgThread2.Execute; 
begin 
  while (not CanTerminated) do 
  begin 
    Sleep(300); 
  end; 
end; 
 
procedure TMsgThread2.NotificationWndProc(var Message: TMessage); 
begin 
  if Message.Msg = WM_CLOSE then 
  begin 
    CanTerminated := True; 
    if CanTerminated then 
    begin 
      FMyString := 'Thread2 QuIT'; 
      Synchronize(ShowString); 
    end; 
  end; 
 
  if Message.Msg = WM_HOTKEY then 
    if (Message.LParamLo = MOD_CONTROL) and (Message.LParamHi = 82) then 
    begin 
      FMyString := 'TMsgThread2 Get Ctrl R!'; 
      Synchronize(ShowString); 
    end; 
end; 
 
procedure TMsgThread2.ShowString; 
begin 
  if assigned(Form1) and assigned(Form1.Memo1) then 
    Form1.Memo1.Lines.Add(FMyString); 
end; 
 
end.

unit Unit1; 
 
interface 
 
{ Reduce EXE size by disabling as much of RTTI as possible (delphi 2009/2010) } 
 
{$IF CompilerVersion >= 21.0} 
 
{$WEAKLINKRTTI ON} 
 
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 
 
{$IFEND} 
 
uses 
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Web.Win.Sockets; 
 
type 
  TForm1 = class(TForm) 
    tcpclnt1: TTcpClient; 
    btn1: TButton; 
    mmo1: TMemo; 
    tcpsrvr1: TTcpServer; 
    btn2: TButton; 
    procedure btn1Click(Sender: TObject); 
    procedure tcpclnt1Connect(Sender: TObject); 
    procedure tcpclnt1Receive(Sender: TObject; Buf: PAnsiChar; 
      var DataLen: Integer); 
    procedure tcpsrvr1Accept(Sender: TObject; ClientSocket: TCustomIpClient); 
    procedure tcpsrvr1GetThread(Sender: TObject; 
      var ClientSocketThread: TClientSocketThread); 
    procedure btn2Click(Sender: TObject); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
  end; 
 
  TServerThread=class(TClientSocketThread) 
  private 
     s:string; 
  protected 
    procedure SyncProc;override; 
  end; 
{ TServerThread } 
 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
procedure TServerThread.SyncProc; 
begin 
   Form1.mmo1.Lines.Add(formatdatetime('mm-dd hh:mm:ss :',now)+s); 
 
end; 
 
 
 
procedure TForm1.btn1Click(Sender: TObject); 
begin 
  if not tcpclnt1.Active then 
  begin 
   tcpclnt1.RemoteHost :='127.0.0.1'; 
   tcpclnt1.RemotePort:='6700'; 
   tcpclnt1.Active:=True; 
  end; 
 
   mmo1.Lines.Add('Send data'); 
   tcpclnt1.Sendln('testdata'); 
end; 
 
procedure TForm1.btn2Click(Sender: TObject); 
begin 
   tcpsrvr1.LocalHost:='127.0.0.1'; 
   tcpsrvr1.LocalPort:='6700'; 
   tcpsrvr1.Active:=True; 
 
end; 
 
procedure TForm1.tcpclnt1Connect(Sender: TObject); 
begin 
    mmo1.Lines.Add('连接服务器'); 
end; 
 
procedure TForm1.tcpclnt1Receive(Sender: TObject; Buf: PAnsiChar; 
  var DataLen: Integer); 
begin 
     mmo1.Lines.Add(StrPas(Buf)); 
end; 
 
procedure TForm1.tcpsrvr1Accept(Sender: TObject; ClientSocket: TCustomIpClient); 
var T:TServerThread; 
    buf:array [0..256] of Char; 
    count:integer; 
begin 
   T:=TServerThread(ClientSocket.GetThreadObject); //获取该线程的对象句柄 
   T.s :=clientsocket.RemoteHost +'已连接'; 
   T.ExecuteSyncProc;     //添加已连接的日志 
   while not T.Terminated and clientsocket.Connected do 
   begin   //该线程未中止和客户端未中止连接时执行 
        if ClientSocket.WaitForData(0) then 
        begin  //如果客户端发送数据 
           count:=8;// ClientSocket.BytesSent; 
           ClientSocket.ReceiveBuf(buf,count); 
           t.s:=StrPas(buf);// ClientSocket.Receiveln();   //接收数据 
           ClientSocket.Sendln('Re:'+t.s);  //回复客户端 
           if t.s='QUIT' then ClientSocket.Disconnect //如果是退出指令,则断开连接 
           else T.SyncProc; //否则添加日志 
        end; 
   end; 
   t.s :=clientsocket.RemoteHost +'已断开';   //添加断开客户端的日志 
   T.ExecuteSyncProc; 
 
   mmo1.Lines.Add('有用户连接'); 
 
end; 
 
procedure TForm1.tcpsrvr1GetThread(Sender: TObject; 
  var ClientSocketThread: TClientSocketThread); 
begin 
    mmo1.Lines.Add('重载获取数据线程'); 
    ClientSocketThread:=TServerThread.Create(tcpsrvr1.ServerSocketThread); 
end; 
 
end.

tcp

(**************************** 
 Unit    : clsMenuEngine 
 Author  : Departure 
 Url     : ic0de.org 
****************************) 
 
unit clsMenuEngine; 
 
interface 
 
uses  Windows, SysUtils, Variants, D3DX9, Direct3D9, DXTypes; 
 
type 
 TItems = packed record 
  strName: PAnsiChar; 
  bOn    : Boolean; 
  bShowCheck: Boolean; 
end; 
 
Type 
 TMenuEngine = Class 
  Private 
   pD3Ddev:  Direct3D9.IDirect3DDevice9; 
   fMenuFont: D3DX9.ID3DXFont; 
 
   bVisable: Boolean; 
   iMenuX, iMenuY, iMenuW, iMenuH, iMenuItems: Integer; 
   dwMenuBgColor, dwMenuBorderColor, dwCrossHairColor, dwTextColor: Dword; 
 
   Function GetDevice():IDirect3DDevice9; 
   function GetFont(): ID3DXFont; 
   procedure DrawRectangle(iXleft, iYtop, iWidth, iHight: Integer; Color: Dword); 
   procedure DrawRectangleAlpha(iXleft, iYtop, iWidth, iHight: Integer; Color: Dword); 
   procedure DrawBorder(); 
   procedure DrawBorderAlpha(); 
   procedure DrawCheck( Color: Dword; x,  y: Integer); 
   procedure DrawDash( Color: Dword; x,  y: Integer); 
   procedure DrawPlus(Color: Dword; x, y: Integer); 
   procedure DrawBox(); 
   procedure DrawBoxAlpha(); 
   procedure DrawText(const iLeft, iTop: Integer; szText: PAnsiChar); 
 
  Public 
   aItems: Array of TItems; 
   Constructor Create( Left, Top, Width, Hight, Items: Integer; BGColor, BDColor, TXTColor: Dword); 
   Destructor Destroy(); Override; 
   Procedure Render(); 
   Procedure Reset(Const pDevice: IDirect3DDevice9); 
   procedure DrawXhair(); 
   procedure MenuItemAdd( iIndex: Integer; szText: PAnsiChar; bOnOff: Boolean; bShowOnOff: Boolean = True); 
 
   Property Direct3DDevice: Direct3D9.IDirect3DDevice9 read pD3Ddev write pD3Ddev; 
 
 
 
   Property MenuLeft: Integer read iMenuX write iMenuX; 
   Property MenuTop: Integer read iMenuY write iMenuY; 
   Property MenuWidth: Integer read iMenuW write iMenuW; 
   Property MenuHight: Integer read iMenuH write iMenuH; 
   Property MenuItems: Integer read iMenuItems write iMenuItems; 
 
   Property BackGroundColor: Dword read dwMenuBgColor write dwMenuBgColor; 
   Property BorderColor: Dword read dwMenuBorderColor write dwMenuBorderColor; 
   Property TextColor: Dword read dwTextColor write dwTextColor; 
 
   Property XHairColor: Dword read dwCrossHairColor write dwCrossHairColor; 
 
   Property Menuvisable: Boolean read bVisable write bVisable; 
 
end; 
 
implementation 
 
{ TMenuEngine } 
 
constructor TMenuEngine.Create( Left, Top, 
  Width, Hight, Items: Integer; BGColor, BDColor, TXTColor: Dword); 
begin 
   MenuLeft:= Left; MenuTop:= Top; MenuWidth:= Width; MenuHight:= Hight; 
   BackGroundColor:= BGColor; BorderColor:= BDColor; TextColor:= TXTColor; 
   MenuItems:= Items; 
   SetLength(aItems,MenuItems); 
end; 
 
destructor TMenuEngine.Destroy; 
var 
 i: Integer; 
begin 
  inherited Destroy(); 
  pD3Ddev:= Nil; 
  fMenuFont:= Nil; 
end; 
 
procedure TMenuEngine.DrawBorder; 
begin 
   DrawRectangle(iMenuX, (iMenuY + iMenuH - 1), iMenuW, 1, dwMenuBorderColor); 
   DrawRectangle(iMenuX, iMenuY, 1, iMenuH, dwMenuBorderColor); 
   DrawRectangle(iMenuX, iMenuY, iMenuW, 1, dwMenuBorderColor); 
   DrawRectangle((iMenuX + iMenuW - 1), iMenuY, 1, iMenuH, dwMenuBorderColor); 
end; 
 
procedure TMenuEngine.DrawBorderAlpha; 
begin 
   DrawRectangleAlpha(iMenuX, (iMenuY + iMenuH - 1), iMenuW, 1, dwMenuBorderColor); 
   DrawRectangleAlpha(iMenuX, iMenuY, 1, iMenuH, dwMenuBorderColor); 
   DrawRectangleAlpha(iMenuX, iMenuY, iMenuW, 1, dwMenuBorderColor); 
   DrawRectangleAlpha((iMenuX + iMenuW - 1), iMenuY, 1, iMenuH, dwMenuBorderColor); 
end; 
 
procedure TMenuEngine.DrawBox; 
begin 
   DrawRectangle(iMenuX, iMenuY, iMenuW, iMenuH, dwMenuBgColor); 
   DrawBorder; 
end; 
 
procedure TMenuEngine.DrawBoxAlpha; 
begin 
   DrawRectangleAlpha(iMenuX, iMenuY, iMenuW, iMenuH, dwMenuBgColor); 
   DrawBorderAlpha; 
end; 
 
procedure TMenuEngine.DrawCheck(Color: Dword; x, y: Integer); 
begin 
  DrawRectangle( x,     y,     1, 3, Color ); 
    DrawRectangle( x + 1, y + 1, 1, 3, Color ); 
    DrawRectangle( x + 2, y + 2, 1, 3, Color ); 
    DrawRectangle( x + 3, y + 1, 1, 3, Color ); 
    DrawRectangle( x + 4, y,     1, 3, Color ); 
    DrawRectangle( x + 5, y - 1, 1, 3, Color ); 
    DrawRectangle( x + 6, y - 2, 1, 3, Color ); 
    DrawRectangle( x + 7, y - 3, 1, 3, Color ); 
end; 
 
procedure TMenuEngine.DrawDash(Color: Dword; x, y: Integer); 
begin 
  DrawRectangle( x , y , 8, 3, Color ); 
end; 
 
procedure TMenuEngine.DrawPlus(Color: Dword; x, y: Integer); 
begin 
   DrawRectangle( x , y , 7, 1, Color ); 
   DrawRectangle( x + 3 , y - 3 , 1, 7, Color ); 
end; 
 
procedure TMenuEngine.DrawRectangle(iXleft, iYtop, iWidth, iHight: Integer; Color: Dword); 
var 
  d3dRectangle : D3DRECT; 
begin 
 
   d3dRectangle.x1:= iXleft; 
   d3dRectangle.y1:= iYtop; 
   d3dRectangle.x2:= iXleft + iWidth; 
   d3dRectangle.y2:= iYtop + iHight; 
 
   Direct3DDevice.Clear(1,@d3dRectangle, D3DCLEAR_TARGET or D3DCLEAR_ZBUFFER, Color, 0, 0); 
end; 
 
procedure TMenuEngine.DrawRectangleAlpha(iXleft, iYtop, iWidth, iHight: Integer; Color: Dword); 
type 
  tStruct = packed record 
    x, y, z, rhw: Single; 
    Color: dWord; 
end; 
procedure AssignVertex(var Vertex: tStruct; x, y, z, rhw: Single; Color: Dword); 
 begin 
   Vertex.x:= x; Vertex.y:= y; Vertex.z:= z; 
   Vertex.Color:= Color; 
 end; 
var 
  qV: array[0..3] of tStruct; 
begin 
 
   AssignVertex(qV[0], iXLeft, iYtop + iHight, 0.0, 0.0, Color); 
   AssignVertex(qV[1], iXLeft, iYtop, 0.0, 0.0, Color); 
   AssignVertex(qV[2], iXLeft + iWidth, iYtop + iHight, 0.0, 0.0, Color); 
   AssignVertex(qV[3], iXLeft + iWidth, iYtop, 0.0, 0.0, Color); 
 
   Direct3DDevice.SetRenderState(D3DRS_ALPHABLENDENABLE,1); 
   Direct3DDevice.SetRenderState(D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA); 
   Direct3DDevice.SetRenderState(D3DRS_ZENABLE, D3DZB_FALSE); 
   Direct3DDevice.SetRenderState(D3DRS_FOGENABLE, 0); 
 
   Direct3DDevice.SetFVF(D3DFVF_XYZRHW or D3DFVF_DIFFUSE); 
   Direct3DDevice.SetTexture(0, Nil); 
   Direct3DDevice.DrawPrimitiveUP(D3DPT_TRIANGLESTRIP,2,qV,SizeOf(tStruct)); 
 
end; 
 
procedure TMenuEngine.DrawText(const iLeft, iTop: Integer; 
  szText: PAnsiChar); 
var 
  d3dRectangle : D3DRECT; 
begin 
  d3dRectangle.x1:= ileft; 
  d3dRectangle.y1:= itop; 
  d3dRectangle.x2:= ileft + 130; 
  d3dRectangle.y2:= itop + 10; 
 
  fMenuFont.DrawTextA(nil, szText, -1, @d3dRectangle, 0{( DT_CALCRECT or DT_NOCLIP )}, dwTextColor); 
 
end; 
 
procedure TMenuEngine.DrawXhair; 
var 
  viewP: D3DVIEWPORT9; 
  ScreenCenterX,ScreenCenterY: DWORD; 
  d3dRectangle1,d3dRectangle2: D3DRECT; 
begin 
  // Get screen 
  Direct3DDevice.GetViewport(viewP); 
  ScreenCenterX:= ((viewP.Width div 2) - 1); 
  ScreenCenterY:= ((viewP.Height div 2) - 1); 
  //Set xhair params 
  d3dRectangle1.x1:= ScreenCenterX-10; 
  d3dRectangle1.y1:= ScreenCenterY; 
  d3dRectangle1.x2:= ScreenCenterX+ 10; 
  d3dRectangle1.y2:= ScreenCenterY+1; 
  d3dRectangle2.x1:= ScreenCenterX; 
  d3dRectangle2.y1:= ScreenCenterY-10; 
  d3dRectangle2.x2:= ScreenCenterX+ 1; 
  d3dRectangle2.y2:= ScreenCenterY+10; 
  //Draw crosshair 
  Direct3DDevice.Clear(1, @d3dRectangle1, D3DCLEAR_TARGET, XHairColor, 0,  0); 
  Direct3DDevice.Clear(1, @d3dRectangle2, D3DCLEAR_TARGET, XHairColor, 0,  0); 
end; 
 
function TMenuEngine.GetDevice: IDirect3DDevice9; 
begin 
  Result:= Direct3DDevice; 
end; 
 
function TMenuEngine.GetFont: ID3DXFont; 
begin 
  Result:= fMenuFont; 
end; 
 
procedure TMenuEngine.MenuItemAdd(iIndex: Integer; szText: PAnsiChar; 
  bOnOff: Boolean; bShowOnOff : Boolean = True); 
begin 
 aItems[pred(iIndex)].strName:= szText; 
 aItems[pred(iIndex)].bOn:= bOnOff; 
 aItems[pred(iIndex)].bShowCheck:= bShowOnOff; 
end; 
 
procedure TMenuEngine.Render; 
var 
 i: integer; 
begin 
   if MenuVisable then 
    begin 
     if MenuHight = 0 then 
      MenuHight:= ((11 * MenuItems)+ 9); 
     DrawBoxAlpha; 
     for i:= 1 to MenuItems do 
      begin 
       If aItems[pred(i)].bShowCheck then 
        begin 
         TextColor:= $FF6746A3; 
         DrawText(MenuLeft + 5,(MenuTop + 5 + (i*11) - 11)  , PChar(aItems[pred(i)].strName)); 
         if i = 2 then 
          DrawPlus(XHairColor, (MenuLeft + MenuWidth) - 12 , (MenuTop + 5 + (i*11) - 11) + 2) 
         else 
         Case aItems[pred(i)].bOn of 
          True: DrawCheck($EE00FF00, (MenuLeft + MenuWidth) - 12 , (MenuTop + 5 + (i*11) - 11) + 2); 
          False: DrawDash($EEFF0000, (MenuLeft + MenuWidth) - 12 , (MenuTop + 5 + (i*11) - 11) + 2); 
         end; 
       end 
       else 
        begin 
          TextColor:= $FFCB7018; 
          DrawText(MenuLeft + 5,(MenuTop + 5 + (i*11) - 11)  , PChar(aItems[pred(i)].strName)); 
        end; 
      end; 
    end; 
end; 
 
procedure TMenuEngine.Reset(Const pDevice: IDirect3DDevice9); 
begin 
   if Direct3DDevice <>  pDevice then 
    begin 
     Direct3DDevice:= pDevice; 
     fMenuFont:= nil; 
    if fMenuFont = nil then 
     D3DXCreateFont(Direct3DDevice,10, 0, FW_BOLD, 1, FALSE, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH or FF_DONTCARE, 'Terminal', fMenuFont); 
   end; 
end; 
 
end.

绘图

//****************************************************************************** 
// 
//  模块名      ：发送字符串消息 
//  版本号      ：1.0 
//  创建者      ：AnderHejlsberg 
//  创建日期    ：2011-9-16 
//  修改者      ： 
//  修改日期    ： 
//  Comment     : 
// 
// 
//****************************************************************************** 
unit uSendStrMsg; 
 
interface 
 
uses 
    Windows, Messages, SysUtils, Variants, Classes, Controls, SyncObjs, Math; 
 
type 
    TShowMsgEvent = procedure(AMsg : string; APointer : Pointer) of object; 
    TFreePointerEvent = procedure(APointer : Pointer) of object; 
 
    TStringMsgObj = class(TThread) 
    Private 
        FShowMsg : TShowMsgEvent; 
        FFreePointer : TFreePointerEvent; 
        FCS : TCriticalSection; 
        FMsgList : TStringList; 
        hSemRequestCount : THandle; 
        hThreadTerminated : THandle; 
        FTerminated : Boolean; 
        procedure DoShowMsg(AMsg : string; APointer : Pointer); 
        procedure DoFreePointer(APointer : Pointer); //执行释放SendMsg参数APointer的事件 
        function GetMsg(var AObj : TObject) : string; 
        function GetMsgCount : integer; 
    Public 
        constructor Create(OnShowMsg : TShowMsgEvent; OnFreePointer : TFreePointerEvent); 
        destructor Destroy; Override; 
        procedure SendMsg(AMsg : string; APointer : Pointer = nil); 
        procedure Execute; Override; 
        procedure Terminate(Force : Boolean = False); 
    Published 
        property MsgCount : integer Read GetMsgCount; 
        property Terminated : Boolean Read FTerminated; 
    end; 
 
implementation 
 
{ TStringMsgObj } 
 
constructor TStringMsgObj.Create(OnShowMsg : TShowMsgEvent; 
    OnFreePointer : TFreePointerEvent); 
begin 
    inherited Create(True); 
    FCS := TCriticalSection.Create; 
    FMsgList := TStringList.Create; 
    hSemRequestCount := CreateSemaphore(nil, 0, $7FFFFFFF, nil); 
    hThreadTerminated := CreateEvent(nil, True, False, nil); 
    FShowMsg := OnShowMsg; 
    FFreePointer := OnFreePointer; 
    FTerminated := False; 
 
    Resume; 
end; 
 
destructor TStringMsgObj.Destroy; 
var 
    AObj            : TObject; 
    AMsg            : string; 
begin 
    CloseHandle(hSemRequestCount); 
    CloseHandle(hThreadTerminated); 
    while True do 
    begin 
        AMsg := GetMsg(AObj); 
        if AMsg = '' then 
            Break; 
        DoFreePointer(AObj); 
    end; 
    FMsgList.Free; 
    FCS.Free; 
    inherited; 
end; 
 
procedure TStringMsgObj.DoFreePointer(APointer : Pointer); 
begin 
    if Assigned(FFreePointer) then 
        FFreePointer(APointer); 
end; 
 
procedure TStringMsgObj.DoShowMsg(AMsg : string; APointer : Pointer); 
begin 
    if Assigned(FShowMsg) then 
        FShowMsg(AMsg, APointer); 
end; 
 
procedure TStringMsgObj.Execute; 
type 
    THandleID = (hidRequest, hidTerminate); 
var 
    Handles         : array[THandleID] of THandle; 
    AObj            : TObject; 
    AMsg            : string; 
begin 
    Handles[hidRequest] := hSemRequestCount; 
    Handles[hidTerminate] := hThreadTerminated; 
    while not Terminated do 
    begin 
        case WaitForMultipleObjects(Length(Handles), @Handles, False, INFINITE) of 
            WAIT_OBJECT_0 + Ord(hidRequest) : 
                begin 
                    AObj := nil; 
                    AMsg := GetMsg(AObj); 
                    if AMsg = '' then 
                        Break; 
                    DoShowMsg(AMsg, Pointer(AObj)); 
                    if AObj <> nil then 
                        DoFreePointer(AObj); 
                end; 
            WAIT_OBJECT_0 + Ord(hidTerminate) : 
                begin 
                    Break; 
                end; 
        end; 
    end; 
end; 
 
function TStringMsgObj.GetMsg(var AObj : TObject) : string; 
begin 
    FCS.Enter; 
    try 
        Result := ''; 
        AObj := nil; 
        if FMsgList.Count > 0 then 
        begin 
            AObj := FMsgList.Objects[0]; 
            Result := FMsgList[0]; 
            FMsgList.Delete(0); 
        end; 
    finally 
        FCS.Leave; 
    end; 
end; 
 
function TStringMsgObj.GetMsgCount : integer; 
begin 
    FCS.Enter; 
    try 
        Result := FMsgList.Count; 
    finally 
        FCS.Leave; 
    end; 
end; 
 
procedure TStringMsgObj.SendMsg(AMsg : string; APointer : Pointer = nil); 
begin 
    FCS.Enter; 
    try 
        FMsgList.AddObject(AMsg, TObject(APointer)); 
        ReleaseSemaphore(hSemRequestCount, 1, nil); 
    finally 
        FCS.Leave; 
    end; 
end; 
 
procedure TStringMsgObj.Terminate(Force : Boolean = False); 
begin 
    inherited Terminate; 
 
    if Force then 
    begin 
        TerminateThread(Handle, 0); 
        Free 
    end 
    else 
    begin 
        FTerminated := True; 
        SetEvent(hThreadTerminated); 
    end; 
end; 
 
end.

发消息

unit FileMap; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, Dialogs; 
 
type 
  TFileMap = class(TComponent) 
  private 
    FMapHandle: THandle; //内存映射文件句柄 
    FMutexHandle: THandle; //互斥句柄 
    FMapName: string; //内存映射对象 
    FSynchMessage: string; //同步消息 
    FMapStrings: TStringList; //存储映射文件信息 
    FSize: DWord; //映射文件大小 
    FMessageID: DWord; //注册的消息号 
    FMapPointer: PChar; //映射文件的数据区指针 
    FLocked: Boolean; //锁定 
    FIsMapOpen: Boolean; //文件是否打开 
    FExistsAlready: Boolean; //是否已经建立过映射文件 
    FReading: Boolean; //是否正在读取内存文件数据 
    FAutoSynch: Boolean; //是否同步 
    FOnChange: TNotifyEvent; //当内存数据区内容改变时 
    FFormHandle: Hwnd; //存储本窗口的窗口句柄 
    FPNewWndHandler: Pointer; 
    FPOldWndHandler: Pointer; 
    procedure SetMapName(Value: string); 
    procedure SetMapStrings(Value: TStringList); 
    procedure SetSize(Value: DWord); 
    procedure SetAutoSynch(Value: Boolean); 
    procedure EnterCriticalSection; 
    procedure LeaveCriticalSection; 
    procedure MapStringsChange(Sender: TObject); 
    procedure NewWndProc(var FMessage: TMessage); 
  public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
    procedure OpenMap; 
    procedure CloseMap; 
    procedure ReadMap; 
    procedure WriteMap; 
    property ExistsAlready: Boolean read FExistsAlready; 
    property IsMapOpen: Boolean read FIsMapOpen; 
  published 
    property MaxSize: DWord read FSize write SetSize; 
    property AutoSynchronize: Boolean read FAutoSynch write SetAutoSynch; 
    property MapName: string read FMapName write SetMapName; 
    property MapStrings: TStringList read FMapStrings write SetMapStrings; 
    property OnChange: TNotifyEvent read FOnChange write FOnChange; 
  end; 
implementation 
 
//构造函数 
 
constructor TFileMap.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  FAutoSynch := True; 
  FSize := 4096; 
  FReading := False; 
  FMapStrings := TStringList.Create; 
  FMapStrings.OnChange := MapStringsChange; 
  FMapName := 'Unique & Common name'; 
  FSynchMessage := FMapName + 'Synch-Now'; 
  if AOwner is TForm then 
  begin 
    FFormHandle := (AOwner as TForm).Handle; 
    //得到窗口处理过程的地址 
    FPOldWndHandler := Ptr(GetWindowLong(FFormHandle, GWL_wNDPROC)); 
    FPNewWndHandler := MakeObjectInstance(NewWndProc); 
    if FPNewWndHandler = nil then 
      raise Exception.Create('超出资源'); 
    //设置窗口处理过程的新地址 
    SetWindowLong(FFormHandle, GWL_WNDPROC, Longint(FPNewWndHandler)); 
  end 
  else raise Exception.Create('组件的所有者应该是TForm'); 
end; 
 
//析构函数 
 
destructor TFileMap.Destroy; 
begin 
  CloseMap; 
  //还原Windows处理过程地址 
  SetWindowLong(FFormHandle, GWL_WNDPROC, Longint(FPOldWndHandler)); 
  if FPNewWndHandler <> nil then 
    FreeObjectInstance(FPNewWndHandler); 
  //释放对象 
  FMapStrings.Free; 
  FMapStrings := nil; 
  inherited destroy; 
end; 
 
 
//打开文件映射，并映射到进程空间 
 
procedure TFileMap.OpenMap; 
var 
  TempMessage: array[0..255] of Char; 
begin 
  if (FMapHandle = 0) and (FMapPointer = nil) then 
  begin 
    FExistsAlready := False; 
    //创建文件映射对象 
    FMapHandle := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, FSize, PChar(FMapName)); 
    if (FMapHandle = INVALID_HANDLE_VALUE) or (FMapHandle = 0) then 
      raise Exception.Create('创建文件映射对象失败!') 
    else 
    begin 
    //判断是否已经建立文件映射了 
      if (FMapHandle <> 0) and (GetLastError = ERROR_ALREADY_EXISTS) then 
        FExistsAlready := True; //如果已经建立的话，就设它为TRUE； 
      //映射文件的使徒到进程的地址空间 
      FMapPointer := MapViewOfFile(FMapHandle, FILE_MAP_ALL_ACCESS, 0, 0, 0); 
      if FMapPointer = nil then 
        raise Exception.Create('映射文件的视图到进程的地址空间失败') 
      else 
      begin 
        StrPCopy(TempMessage, FSynchMessage); 
        //在WINDOWS中注册消息常量 
        FMessageID := RegisterWindowMessage(TempMessage); 
        if FMessageID = 0 then 
          raise Exception.Create('注册消息失败') 
      end 
    end; 
    //创建互斥对象，在写文件映射空间时用到它，以保持数据同步 
    FMutexHandle := Windows.CreateMutex(nil, False, PChar(FMapName + '.Mtx')); 
    if FMutexHandle = 0 then 
      raise Exception.Create('创建互斥对象失败'); 
    FIsMapOpen := True; 
    if FExistsAlready then //判断内存文件映射是否已打开 
      ReadMap 
    else 
      WriteMap; 
  end; 
end; 
 
//解除文件视图和内存映射空间的关系，并关闭文件映射 
 
procedure TFileMap.CloseMap; 
begin 
  if FIsMapOpen then 
  begin 
    //释放互斥对象 
    if FMutexHandle <> 0 then 
    begin 
      CloseHandle(FMutexHandle); 
      FMutexHandle := 0; 
    end; 
    //关闭内存对象 
    if FMapPointer <> nil then 
    begin 
    //解除文件视图和内存映射空间的关系 
      UnMapViewOfFile(FMapPointer); 
      FMapPointer := nil; 
    end; 
    if FMapHandle <> 0 then 
    begin 
    //并关闭文件映射 
      CloseHandle(FMapHandle); 
      FMapHandle := 0; 
    end; 
    FIsMapOpen := False; 
  end; 
end; 
 
//读取内存文件映射内容 
 
procedure TFileMap.ReadMap; 
begin 
  FReading := True; 
  if (FMapPointer <> nil) then FMapStrings.SetText(FMapPointer); 
end; 
 
//向内存映射文件里写 
 
procedure TFileMap.WriteMap; 
var 
  StringsPointer: PChar; 
//  HandleCounter: integer; 
//  SendToHandle: HWnd; 
begin 
  if FMapPointer <> nil then 
  begin 
    StringsPointer := FMapStrings.GetText; 
    //进入互斥状态，防止其他线程进入同步区域代码 
    EnterCriticalSection; 
    if StrLen(StringsPointer) + 1 <= FSize 
      then System.Move(StringsPointer^, FMapPointer^, StrLen(StringsPointer) + 1) 
    else 
      raise Exception.Create('写字符串失败，字符串太大！'); 
    //离开互斥状态 
    LeaveCriticalSection; 
    //广播消息，表示内存映射文件内容已经修改 
    SendMessage(HWND_BROADCAST, FMessageID, FFormHandle, 0); 
    //释放StringsPointer 
    StrDispose(StringsPointer); 
  end; 
end; 
 
//当MapStrings值改变时 
 
procedure TFileMap.MapStringsChange(Sender: TObject); 
begin 
  if FReading and Assigned(FOnChange) then 
    FOnChange(Self) 
  else if (not FReading) and FIsMapOpen and FAutoSynch then 
    WriteMap; 
end; 
 
//设置MapName属性值 
 
procedure TFileMap.SetMapName(Value: string); 
begin 
  if (FMapName <> Value) and (FMapHandle = 0) and (Length(Value) < 246) then 
  begin 
    FMapName := Value; 
    FSynchMessage := FMapName + 'Synch-Now'; 
  end; 
end; 
 
//设置MapStrings属性值 
 
procedure TFileMap.SetMapStrings(Value: TStringList); 
begin 
  if Value.Text <> FMapStrings.Text then 
  begin 
    if Length(Value.Text) <= FSize then 
      FMapStrings.Assign(Value) 
    else 
      raise Exception.Create('写入值太大'); 
  end; 
end; 
 
//设置内存文件大小 
 
procedure TFileMap.SetSize(Value: DWord); 
var 
  StringsPointer: PChar; 
begin 
  if (FSize <> Value) and (FMapHandle = 0) then 
  begin 
    StringsPointer := FMapStrings.GetText; 
    if (Value < StrLen(StringsPointer) + 1) then 
      FSize := StrLen(StringsPointer) + 1 
    else FSize := Value; 
    if FSize < 32 then FSize := 32; 
    StrDispose(StringsPointer); 
  end; 
end; 
 
//设置是否同步 
 
procedure TFileMap.SetAutoSynch(Value: Boolean); 
begin 
  if FAutoSynch <> Value then 
  begin 
    FAutoSynch := Value; 
    if FAutoSynch and FIsMapOpen then WriteMap; 
  end; 
end; 
 
//进入互斥，使得被同步的代码不能被别的线程访问 
 
procedure TFileMap.EnterCriticalSection; 
begin 
  if (FMutexHandle <> 0) and not FLocked then 
  begin 
    FLocked := (WaitForSingleObject(FMutexHandle, INFINITE) = WAIT_OBJECT_0); 
  end; 
end; 
 
//解除互斥关系，可以进入保护的同步代码区 
 
procedure TFileMap.LeaveCriticalSection; 
begin 
  if (FMutexHandle <> 0) and FLocked then 
  begin 
    ReleaseMutex(FMutexHandle); 
    FLocked := False; 
  end; 
end; 
 
//消息捕获过程 
 
procedure TFileMap.NewWndProc(var FMessage: TMessage); 
begin 
  with FMessage do 
  begin 
    if FIsMapOpen then //内存文件打开 
    {如果消息是FMessageID,且WParam不是FFormHandle，就调用 
     ReadMap去读取内存映射文件的内容，表示内存映射文件的 
     内容已变} 
      if (Msg = FMessageID) and (WParam <> FFormHandle) then 
        ReadMap; 
    Result := CallWindowProc(FPOldWndHandler, FFormHandle, Msg, wParam, lParam); 
  end; 
end; 
 
end. 
 


unit Unit1; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls,FileMap; 
 
type 
  TForm1 = class(TForm) 
    Memo1: TMemo; 
    Button1: TButton; 
    Button2: TButton; 
    Button3: TButton; 
    Button4: TButton; 
    Button5: TButton; 
    CheckBox1: TCheckBox; 
    CheckBox2: TCheckBox; 
    CheckBox3: TCheckBox; 
    procedure FormCreate(Sender: TObject); 
    procedure Button4Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
    procedure Button5Click(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure CheckBox1Click(Sender: TObject); 
    procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure Memo1KeyUp(Sender: TObject; var Key: Word; 
      Shift: TShiftState); 
  private 
    { Private declarations } 
        //定义TFileMap对象 
    FileMap: TFileMap; 
    //定义FileMapChange用于赋给FileMap的OnChange事件 
    procedure FileMapChange(Sender: TObject); 
    procedure Check; 
  public 
    { Public declarations } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
{ TForm1 } 
 
procedure TForm1.Check; 
begin 
  CheckBox2.Checked:=FileMap.ExistsAlready; 
  CheckBox3.Checked:=FileMap.IsMapOpen; 
end; 
 
procedure TForm1.FileMapChange(Sender: TObject); 
begin 
   memo1.Lines.Assign(FileMap.MapStrings); 
   check; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  //创建FileMap 
  FileMap:=TFileMap.Create(self); 
  FileMap.OnChange:=FileMapchange; 
  CheckBox1.Checked:=FileMap.AutoSynchronize; 
  //如果内存对象还未创建，初始化FileMap里的内容 
  if not FileMap.ExistsAlready then 
  begin 
    memo1.Lines.LoadFromFile('readme.txt'); 
    FileMap.MapStrings.Assign(memo1.Lines); 
  end; 
end; 
 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  FileMap.WriteMap; 
end; 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  FileMap.ReadMap; 
end; 
 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  memo1.Clear; 
  FileMap.MapStrings.Clear; 
  check; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
FileMap.MapName:='Delphi 7'; 
  FileMap.OpenMap; 
  check; 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  FileMap.CloseMap; 
  check; 
end; 
 
procedure TForm1.CheckBox1Click(Sender: TObject); 
begin 
  FileMap.AutoSynchronize:=CheckBox1.checked; 
end; 
 
procedure TForm1.Memo1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
FileMap.MapStrings.Assign(memo1.Lines); 
end; 
 
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; 
  Shift: TShiftState); 
begin 
  FileMap.MapStrings.Assign(memo1.Lines); 
end; 
 
end. 
 


object Form1: TForm1 
  Left = 277 
  Top = 282 
  Width = 979 
  Height = 563 
  Caption = 'Form1' 
  Color = clBtnFace 
  Font.Charset = DEFAULT_CHARSET 
  Font.Color = clWindowText 
  Font.Height = -11 
  Font.Name = 'MS Sans Serif' 
  Font.Style = [] 
  OldCreateOrder = False 
  OnCreate = FormCreate 
  PixelsPerInch = 96 
  TextHeight = 13 
  object Memo1: TMemo 
    Left = 56 
    Top = 40 
    Width = 209 
    Height = 369 
    Lines.Strings = ( 
      'Memo1') 
    ScrollBars = ssVertical 
    TabOrder = 0 
    OnKeyUp = Memo1KeyUp 
    OnMouseDown = Memo1MouseDown 
  end 
  object Button1: TButton 
    Left = 304 
    Top = 40 
    Width = 75 
    Height = 25 
    Caption = 'OpenMap' 
    TabOrder = 1 
    OnClick = Button1Click 
  end 
  object Button2: TButton 
    Left = 304 
    Top = 74 
    Width = 75 
    Height = 25 
    Caption = 'CloseMap' 
    TabOrder = 2 
    OnClick = Button2Click 
  end 
  object Button3: TButton 
    Left = 304 
    Top = 108 
    Width = 75 
    Height = 25 
    Caption = 'ReadMap' 
    TabOrder = 3 
    OnClick = Button3Click 
  end 
  object Button4: TButton 
    Left = 304 
    Top = 142 
    Width = 75 
    Height = 25 
    Caption = 'WriteMap' 
    TabOrder = 4 
    OnClick = Button4Click 
  end 
  object Button5: TButton 
    Left = 304 
    Top = 176 
    Width = 75 
    Height = 25 
    Caption = 'Clear' 
    TabOrder = 5 
    OnClick = Button5Click 
  end 
  object CheckBox1: TCheckBox 
    Left = 408 
    Top = 40 
    Width = 97 
    Height = 17 
    Caption = 'AutoSynchronize' 
    TabOrder = 6 
    OnClick = CheckBox1Click 
  end 
  object CheckBox2: TCheckBox 
    Left = 408 
    Top = 72 
    Width = 97 
    Height = 17 
    Caption = 'ExistsAlready' 
    TabOrder = 7 
  end 
  object CheckBox3: TCheckBox 
    Left = 408 
    Top = 104 
    Width = 97 
    Height = 17 
    Caption = 'IsMapOpen' 
    TabOrder = 8 
  end 
end

共享内存以及使用

/////////////////////////////////////////////////////////////////////////////// 
                         //Base64 DEMO V1.0// 
                          //作者：ksaiy// 
//欢迎使用由ksaiy制作的Base64加密算法演示程序，此算法为标准的Base64算法，你可以 
//根据的的自己需要进行变形。具体怎么操作可以登录我们的网站查询详细的资料。我们专 
//门为软件开发者提供软件加密安全测试服务和软件加密解决方案，具体的可以参看我们的 
//网站上的资料。我们的网站：http://www.ksaiy.com  http://www.magicoa.com 
//技术支持:ksaiy@sina.com 在线QQ：40188696 UC：934155 
                            //End // 
 
                  //注意：转载请保留以上信息。//                             
/////////////////////////////////////////////////////////////////////////////// 
 
unit Unit1; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls; 
 
type 
  TForm1 = class(TForm) 
    Label1: TLabel; 
    Label2: TLabel; 
    Label3: TLabel; 
    Edit1: TEdit; 
    Edit2: TEdit; 
    Button1: TButton; 
    Button2: TButton; 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
  end; 
 
function MimeEncodeString (const s: AnsiString): AnsiString; 
function MimeEncodeStringNoCRLF (const s: AnsiString): AnsiString; 
function MimeDecodeString (const s: AnsiString): AnsiString; 
procedure MimeEncodeStream (const InputStream: TStream; const OutputStream: TStream); 
procedure MimeEncodeStreamNoCRLF (const InputStream: TStream; const OutputStream: TStream); 
procedure MimeDecodeStream (const InputStream: TStream; const OutputStream: TStream); 
function MimeEncodedSize (const i: Cardinal): Cardinal; 
function MimeEncodedSizeNoCRLF (const i: Cardinal): Cardinal; 
function MimeDecodedSize (const i: Cardinal): Cardinal; 
procedure DecodeHttpBasicAuthentication (const BasicCredentials: AnsiString; 
  out UserId, PassWord: AnsiString); 
procedure MimeEncode (const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer); 
procedure MimeEncodeNoCRLF (const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer); 
procedure MimeEncodeFullLines (const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer); 
function MimeDecode (const InputBuffer; const InputBytesCount: Cardinal; out OutputBuffer): Cardinal; 
function MimeDecodePartial (const InputBuffer; const InputBytesCount: Cardinal; 
  out OutputBuffer; var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): Cardinal; 
function MimeDecodePartialEnd (out OutputBuffer; const ByteBuffer: Cardinal; 
  const ByteBufferSpace: Cardinal): Cardinal; 
procedure Base64Encode(InputFile, OutputFile: string); 
procedure Base64Decode(InputFile, OutputFile: string); 
//Download by http://www.codefans.net 
const 
 MIME_ENCODED_LINE_BREAK = 76; 
 MIME_DECODED_LINE_BREAK = MIME_ENCODED_LINE_BREAK div 4 * 3; 
 BUFFER_SIZE        = MIME_DECODED_LINE_BREAK * 3 * 4 * 16; 
 MIME_ENCODE_TABLE  : array[0..63] of Byte = ( 
  065, 066, 067, 068, 069, 070, 071, 072, // 00 - 07 
  073, 074, 075, 076, 077, 078, 079, 080, // 08 - 15 
  081, 082, 083, 084, 085, 086, 087, 088, // 16 - 23 
  089, 090, 097, 098, 099, 100, 101, 102, // 24 - 31 
  103, 104, 105, 106, 107, 108, 109, 110, // 32 - 39 
  111, 112, 113, 114, 115, 116, 117, 118, // 40 - 47 
  119, 120, 121, 122, 048, 049, 050, 051, // 48 - 55 
  052, 053, 054, 055, 056, 057, 043, 047); // 56 - 63 
 
 MIME_PAD_CHAR      = Byte ('='); 
 
 MIME_DECODE_TABLE  : array[Byte] of Cardinal = ( 
  255, 255, 255, 255, 255, 255, 255, 255, //  00 -  07 
  255, 255, 255, 255, 255, 255, 255, 255, //  08 -  15 
  255, 255, 255, 255, 255, 255, 255, 255, //  16 -  23 
  255, 255, 255, 255, 255, 255, 255, 255, //  24 -  31 
  255, 255, 255, 255, 255, 255, 255, 255, //  32 -  39 
  255, 255, 255, 062, 255, 255, 255, 063, //  40 -  47 
  052, 053, 054, 055, 056, 057, 058, 059, //  48 -  55 
  060, 061, 255, 255, 255, 255, 255, 255, //  56 -  63 
  255, 000, 001, 002, 003, 004, 005, 006, //  64 -  71 
  007, 008, 009, 010, 011, 012, 013, 014, //  72 -  79 
  015, 016, 017, 018, 019, 020, 021, 022, //  80 -  87 
  023, 024, 025, 255, 255, 255, 255, 255, //  88 -  95 
  255, 026, 027, 028, 029, 030, 031, 032, //  96 - 103 
  033, 034, 035, 036, 037, 038, 039, 040, // 104 - 111 
  041, 042, 043, 044, 045, 046, 047, 048, // 112 - 119 
  049, 050, 051, 255, 255, 255, 255, 255, // 120 - 127 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255, 
  255, 255, 255, 255, 255, 255, 255, 255); 
 
type 
 PByte4 = ^TByte4; 
 TByte4 = packed record 
  b1: Byte; 
  b2: Byte; 
  b3: Byte; 
  b4: Byte; 
 end; 
 
 PByte3 = ^TByte3; 
 TByte3 = packed record 
  b1: Byte; 
  b2: Byte; 
  b3: Byte; 
 end; 
   
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
function MimeEncodeString (const s: AnsiString): AnsiString; 
var 
 l                  : Cardinal; 
begin 
 if Pointer (s) <> nil then 
  begin 
   l := Cardinal (Pointer (Cardinal (s) - 4)^); 
   SetLength (Result, MimeEncodedSize (l)); 
   MimeEncode (Pointer (s)^, l, Pointer (Result)^); 
  end 
 else 
  Result := ''; 
end; 
 
function MimeEncodeStringNoCRLF (const s: AnsiString): AnsiString; 
var 
 l                  : Cardinal; 
begin 
 if Pointer (s) <> nil then 
  begin 
   l := Cardinal (Pointer (Cardinal (s) - 4)^); 
   SetLength (Result, MimeEncodedSizeNoCRLF (l)); 
   MimeEncodeNoCRLF (Pointer (s)^, l, Pointer (Result)^); 
  end 
 else 
  Result := ''; 
end; 
 
function MimeDecodeString (const s: AnsiString): AnsiString; 
var 
 ByteBuffer, ByteBufferSpace: Cardinal; 
 l                  : Cardinal; 
begin 
 if Pointer (s) <> nil then 
  begin 
   l := Cardinal (Pointer (Cardinal (s) - 4)^); 
   SetLength (Result, (l + 3) div 4 * 3); 
   ByteBuffer := 0; 
   ByteBufferSpace := 4; 
   l := MimeDecodePartial (Pointer (s)^, l, Pointer (Result)^, ByteBuffer, ByteBufferSpace); 
   Inc (l, MimeDecodePartialEnd (Pointer (Cardinal (Result) + l)^, 
     ByteBuffer, ByteBufferSpace)); 
   SetLength (Result, l); 
  end 
 else 
  Result := ''; 
end; 
 
procedure MimeEncodeStream (const InputStream: TStream; const OutputStream: TStream); 
var 
 InputBuffer : array[0..BUFFER_SIZE - 1] of Byte; 
 OutputBuffer : array[0.. (BUFFER_SIZE + 2) div 3 * 4 + BUFFER_SIZE div  
   MIME_DECODED_LINE_BREAK * 2 - 1] of Byte; 
 BytesRead : Cardinal; 
 IDelta, ODelta : Cardinal; 
begin 
 BytesRead := InputStream.Read (InputBuffer, SizeOf (InputBuffer)); 
  
 while BytesRead = SizeOf (InputBuffer) do 
  begin 
   MimeEncodeFullLines (InputBuffer, SizeOf (InputBuffer), OutputBuffer); 
   OutputStream.Write (OutputBuffer, SizeOf (OutputBuffer)); 
   BytesRead := InputStream.Read (InputBuffer, SizeOf (InputBuffer)); 
  end; 
 
 MimeEncodeFullLines (InputBuffer, BytesRead, OutputBuffer); 
  
 IDelta := BytesRead div MIME_DECODED_LINE_BREAK; // Number of lines processed. 
 ODelta := IDelta * (MIME_ENCODED_LINE_BREAK + 2); 
 IDelta := IDelta * MIME_DECODED_LINE_BREAK; 
 MimeEncodeNoCRLF(Pointer(Cardinal (@InputBuffer) + IDelta)^, BytesRead - IDelta,  
   Pointer (Cardinal (@OutputBuffer) + ODelta)^); 
  
 OutputStream.Write (OutputBuffer, MimeEncodedSize (BytesRead)); 
end; 
 
procedure MimeEncodeStreamNoCRLF (const InputStream: TStream; const OutputStream: TStream); 
var 
 InputBuffer        : array[0..BUFFER_SIZE - 1] of Byte; 
 OutputBuffer       : array[0.. ((BUFFER_SIZE + 2) div 3) * 4 - 1] of Byte; 
 BytesRead          : Cardinal; 
begin 
 BytesRead := InputStream.Read (InputBuffer, SizeOf (InputBuffer)); 
 while BytesRead = SizeOf (InputBuffer) do 
  begin 
   MimeEncodeNoCRLF (InputBuffer, SizeOf (InputBuffer), OutputBuffer); 
   OutputStream.Write (OutputBuffer, SizeOf (OutputBuffer)); 
   BytesRead := InputStream.Read (InputBuffer, SizeOf (InputBuffer)); 
  end; 
 
 MimeEncodeNoCRLF (InputBuffer, BytesRead, OutputBuffer); 
 OutputStream.Write (OutputBuffer, (BytesRead + 2) div 3 * 4); 
end; 
 
procedure MimeDecodeStream (const InputStream: TStream; const OutputStream: TStream); 
var 
 ByteBuffer, ByteBufferSpace: Cardinal; 
 InputBuffer        : array[0..BUFFER_SIZE - 1] of Byte; 
 OutputBuffer       : array[0.. (BUFFER_SIZE + 3) div 4 * 3 - 1] of Byte; 
 BytesRead          : Cardinal; 
begin 
 ByteBuffer := 0; 
 ByteBufferSpace := 4; 
 BytesRead := InputStream.Read (InputBuffer, SizeOf (InputBuffer)); 
 while BytesRead > 0 do 
  begin 
   OutputStream.Write(OutputBuffer, MimeDecodePartial(InputBuffer, BytesRead,  
     OutputBuffer, ByteBuffer, ByteBufferSpace)); 
   BytesRead := InputStream.Read (InputBuffer, SizeOf (InputBuffer)); 
  end; 
 OutputStream.Write (OutputBuffer, MimeDecodePartialEnd (OutputBuffer, ByteBuffer,  
   ByteBufferSpace)); 
end; 
 
procedure DecodeHttpBasicAuthentication (const BasicCredentials: AnsiString; out UserId, PassWord: AnsiString); 
label 
 Fail; 
const 
 LBasic = 6;                { Length ('Basic ') } 
var 
 DecodedPtr, p      : PAnsiChar; 
 i, l               : Cardinal; 
begin 
 p := Pointer (BasicCredentials); 
 if p = nil then goto Fail; 
  
 l := Cardinal (Pointer (p - 4)^); 
 if l <= LBasic then goto Fail; 
  
 Dec (l, LBasic); 
 Inc (p, LBasic); 
  
 GetMem (DecodedPtr, (l + 3) div 4 * 3 { MimeDecodedSize (l) }); 
 l := MimeDecode (p^, l, DecodedPtr^); 
 i := 0; 
 p := DecodedPtr; 
 while (l > 0) and (p[i] <> ':') do 
  begin 
   Inc (i); 
   Dec (l); 
  end; 
 SetString (UserId, DecodedPtr, i); 
 if l > 1 then 
  SetString (PassWord, DecodedPtr + i + 1, l - 1) 
 else 
  PassWord := ''; 
  
 FreeMem (DecodedPtr); 
 Exit; 
  
 Fail: 
 UserId := ''; 
 PassWord := ''; 
end; 
 
function MimeEncodedSize (const i: Cardinal): Cardinal; 
begin 
 Result := (i + 2) div 3 * 4 + (i - 1) div MIME_DECODED_LINE_BREAK * 2; 
end; 
 
function MimeEncodedSizeNoCRLF (const i: Cardinal): Cardinal; 
begin 
 Result := (i + 2) div 3 * 4; 
end; 
 
function MimeDecodedSize (const i: Cardinal): Cardinal; 
begin 
 Result := (i + 3) div 4 * 3; 
end; 
 
procedure MimeEncode (const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer); 
var 
 IDelta, ODelta     : Cardinal; 
begin 
 MimeEncodeFullLines (InputBuffer, InputByteCount, OutputBuffer); 
 IDelta := InputByteCount div MIME_DECODED_LINE_BREAK;  
 ODelta := IDelta * (MIME_ENCODED_LINE_BREAK + 2); 
 IDelta := IDelta * MIME_DECODED_LINE_BREAK; 
 MimeEncodeNoCRLF (Pointer (Cardinal (@InputBuffer) + IDelta)^,  
  InputByteCount - IDelta, Pointer (Cardinal (@OutputBuffer) + ODelta)^); 
end; 
 
procedure MimeEncodeFullLines (const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer); 
var 
 b, OuterLimit      : Cardinal; 
 InPtr, InnerLimit  : ^Byte; 
 OutPtr             : PByte4; 
begin 
 if InputByteCount = 0 then Exit; 
 InPtr := @InputBuffer; 
 OutPtr := @OutputBuffer; 
  
 InnerLimit := InPtr; 
 Inc (Cardinal (InnerLimit), MIME_DECODED_LINE_BREAK); 
  
 OuterLimit := Cardinal (InPtr); 
 Inc (OuterLimit, InputByteCount); 
 
 while Cardinal (InnerLimit) <= OuterLimit do 
  begin 
 
   while InPtr <> InnerLimit do 
    begin 
     b := InPtr^; 
     b := b shl 8; 
     Inc (InPtr); 
     b := b or InPtr^; 
     b := b shl 8; 
     Inc (InPtr); 
     b := b or InPtr^; 
     Inc (InPtr); 
     OutPtr^.b4 := MIME_ENCODE_TABLE[b and $3F]; 
     b := b shr 6; 
     OutPtr^.b3 := MIME_ENCODE_TABLE[b and $3F]; 
     b := b shr 6; 
     OutPtr^.b2 := MIME_ENCODE_TABLE[b and $3F]; 
     b := b shr 6; 
     OutPtr^.b1 := MIME_ENCODE_TABLE[b]; 
     Inc (OutPtr); 
    end; 
   OutPtr^.b1 := 13; 
   OutPtr^.b2 := 10; 
   Inc (Cardinal (OutPtr), 2); 
 
   Inc (InnerLimit, MIME_DECODED_LINE_BREAK); 
  end; 
  
end; 
 
procedure MimeEncodeNoCRLF (const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer); 
var 
 b, OuterLimit      : Cardinal; 
 InPtr, InnerLimit  : ^Byte; 
 OutPtr             : PByte4; 
begin 
 if InputByteCount = 0 then Exit; 
 InPtr := @InputBuffer; 
 OutPtr := @OutputBuffer; 
  
 OuterLimit := InputByteCount div 3 * 3; 
  
 InnerLimit := @InputBuffer; 
 Inc (Cardinal (InnerLimit), OuterLimit); 
 while InPtr <> InnerLimit do 
  begin 
   b := InPtr^; 
   b := b shl 8; 
   Inc (InPtr); 
   b := b or InPtr^; 
   b := b shl 8; 
   Inc (InPtr); 
   b := b or InPtr^; 
   Inc (InPtr); 
   OutPtr^.b4 := MIME_ENCODE_TABLE[b and $3F]; 
   b := b shr 6; 
   OutPtr^.b3 := MIME_ENCODE_TABLE[b and $3F]; 
   b := b shr 6; 
   OutPtr^.b2 := MIME_ENCODE_TABLE[b and $3F]; 
   b := b shr 6; 
   OutPtr^.b1 := MIME_ENCODE_TABLE[b]; 
   Inc (OutPtr); 
  end; 
 case InputByteCount - OuterLimit of 
  1: 
   begin 
    b := InPtr^; 
    b := b shl 4; 
    OutPtr.b2 := MIME_ENCODE_TABLE[b and $3F]; 
    b := b shr 6; 
    OutPtr.b1 := MIME_ENCODE_TABLE[b]; 
    OutPtr.b3 := MIME_PAD_CHAR;          
    OutPtr.b4 := MIME_PAD_CHAR; 
   end; 
  2: 
   begin 
    b := InPtr^; 
    Inc (InPtr); 
    b := b shl 8; 
    b := b or InPtr^; 
    b := b shl 2; 
    OutPtr.b3 := MIME_ENCODE_TABLE[b and $3F]; 
    b := b shr 6; 
    OutPtr.b2 := MIME_ENCODE_TABLE[b and $3F]; 
    b := b shr 6; 
    OutPtr.b1 := MIME_ENCODE_TABLE[b]; 
    OutPtr.b4 := MIME_PAD_CHAR;         { Pad remaining byte. } 
   end; 
 end; 
end; 
 
function MimeDecode (const InputBuffer; const InputBytesCount: Cardinal; 
  out OutputBuffer): Cardinal; 
var 
 ByteBuffer, ByteBufferSpace: Cardinal; 
begin 
 ByteBuffer := 0; 
 ByteBufferSpace := 4; 
 Result := MimeDecodePartial(InputBuffer, InputBytesCount, 
  OutputBuffer, ByteBuffer, ByteBufferSpace); 
 Inc (Result, MimeDecodePartialEnd(Pointer (Cardinal(@OutputBuffer) + Result)^, 
  ByteBuffer, ByteBufferSpace)); 
end; 
 
function MimeDecodePartial (const InputBuffer; const InputBytesCount: Cardinal;  
  out OutputBuffer; var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): Cardinal; 
var 
 lByteBuffer, lByteBufferSpace, c: Cardinal; 
 InPtr, OuterLimit  : ^Byte; 
 OutPtr             : PByte3; 
begin 
 if InputBytesCount > 0 then 
  begin 
   InPtr := @InputBuffer; 
   Cardinal (OuterLimit) := Cardinal (InPtr) + InputBytesCount; 
   OutPtr := @OutputBuffer; 
   lByteBuffer := ByteBuffer; 
   lByteBufferSpace := ByteBufferSpace; 
   while InPtr <> OuterLimit do 
    begin 
     c := MIME_DECODE_TABLE[InPtr^]; 
     Inc (InPtr); 
     if c = $FF then Continue; 
     lByteBuffer := lByteBuffer shl 6; 
     lByteBuffer := lByteBuffer or c; 
     Dec (lByteBufferSpace); 
     if lByteBufferSpace <> 0 then Continue; 
     OutPtr^.b3 := Byte (lByteBuffer); 
     lByteBuffer := lByteBuffer shr 8; 
     OutPtr^.b2 := Byte (lByteBuffer); 
     lByteBuffer := lByteBuffer shr 8; 
     OutPtr^.b1 := Byte (lByteBuffer); 
     lByteBuffer := 0; 
     Inc (OutPtr); 
     lByteBufferSpace := 4; 
    end; 
   ByteBuffer := lByteBuffer; 
   ByteBufferSpace := lByteBufferSpace; 
   Result := Cardinal (OutPtr) - Cardinal (@OutputBuffer); 
  end 
 else 
  Result := 0; 
end; 
 
function MimeDecodePartialEnd (out OutputBuffer; const ByteBuffer: Cardinal;  
  const ByteBufferSpace: Cardinal): Cardinal; 
var 
 lByteBuffer : Cardinal; 
begin 
 case ByteBufferSpace of 
  1: 
   begin 
    lByteBuffer := ByteBuffer shr 2; 
    PByte3 (@OutputBuffer)^.b2 := Byte (lByteBuffer); 
    lByteBuffer := lByteBuffer shr 8; 
    PByte3 (@OutputBuffer)^.b1 := Byte (lByteBuffer); 
    Result := 2; 
   end; 
  2: 
   begin 
    lByteBuffer := ByteBuffer shr 4; 
    PByte3 (@OutputBuffer)^.b1 := Byte (lByteBuffer); 
    Result := 1; 
   end; 
  else 
   Result := 0; 
 end; 
end; 
 
procedure Base64Encode(InputFile, OutputFile: string); 
var 
  Ms: TMemoryStream; 
  Ss: TStringStream; 
  Str: string; 
  List: TStringList; 
begin {Base64 encode}  
  Ms := TMemoryStream.Create; 
  try 
    Ms.LoadFromFile(InputFile); 
    Ss := TStringStream.Create(Str); 
    try 
      MimeEncodeStream(Ms, Ss); 
      List := TStringList.Create; 
      try 
        List.Text := Ss.DataString; 
        List.SaveToFile(OutputFile); 
      finally 
        List.Free; 
      end; 
    finally 
      Ss.Free; 
    end; 
  finally 
    Ms.Free; 
  end; 
end; 
 
procedure Base64Decode(InputFile, OutputFile: string); 
var 
  Ms: TMemoryStream; 
  Ss: TStringStream; 
  List: TStringList; 
begin {Base64 decode} 
  List := TStringList.Create; 
  try 
    List.LoadFromFile(InputFile); 
    Ss := TStringStream.Create(List.Text); 
    try 
      Ms := TMemoryStream.Create; 
      try 
        MimeDecodeStream(Ss, Ms); 
        Ms.SaveToFile(OutputFile); 
      finally 
        Ms.Free; 
      end; 
    finally 
      Ss.Free; 
    end; 
  finally 
    List.Free; 
  end; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
//function MimeEncodeString (const s: AnsiString): AnsiString;//加密字符串函数； 
//function MimeDecodeString (const s: AnsiString): AnsiString;//解密字符串函数； 
  if MimeEncodeString(Edit1.Text)=Edit2.Text then 
    ShowMessage('注册成功！') 
  else 
    ShowMessage('注册失败！'); 
/////////////////////////////////////////////////////////////////////////////// 
                         //Base64 DEMO V1.0// 
                          //作者：ksaiy// 
//欢迎使用由ksaiy制作的Base64加密算法演示程序，此算法为标准的Base64算法，你可以 
//根据的的自己需要进行变形。具体怎么操作可以登录我们的网站查询详细的资料。我们专 
//门为软件开发者提供软件加密安全测试服务和软件加密解决方案，具体的可以参看我们的 
//网站上的资料。我们的网站：http://www.ksaiy.com  http://www.magicoa.com 
//技术支持:ksaiy@sina.com 在线QQ：40188696 UC：934155 
                            //End // 
 
                  //注意：转载请保留以上信息。//                             
/////////////////////////////////////////////////////////////////////////////// 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Close; 
end; 
 
end.

base64

 
//第1种花指令 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    jb @label 
    jnb @label 
    db $E8 
    @label: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第2种花指令 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    je @label 
    jne @label 
    db $E8 
    @label: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第3种花指令 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    jbe @label 
    ja @label 
    db $E8 
    @label: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第4种花指令 
procedure TForm1.Button4Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    js @label 
    jns @label 
    db $E8 
    @label: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第5种花指令 
procedure TForm1.Button5Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    jpe @label 
    jpo @label 
    db $E8 
    @label: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第6种花指令 
procedure TForm1.Button6Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    jl @label 
    jge @label 
    db $E8 
    @label: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第7种花指令 
procedure TForm1.Button7Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    jle @label 
    jg @label 
    db $E8 
    @label: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第8种花指令 
procedure TForm1.Button8Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    jz @label 
    jnz @label 
    db $E8 
    @label: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第9种花指令 
procedure TForm1.Button9Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    push ecx 
    xor ecx,ecx 
    jcxz @label 
    db $E8 
    @label: 
    pop ecx 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第10种花指令 
procedure TForm1.Button10Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    jl @label1 
    @label2: 
    jmp @label3 
    db $E8 
    @label1: 
    jz @label2 
    @label3: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第11种花指令 
procedure TForm1.Button11Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    call @label1 
    db $E8 
    jmp @label2 
    db $E8 
  @label1: 
    pop eax 
    jmp @label3 
    db $E8,$E8,$E8 
  @label3: 
    inc eax 
    jmp @label4 
    db $E8,$E8,$E8 
  @label4: 
    jmp eax 
    db $E8 
  @label2: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 
 
//第12种花指令 
procedure TForm1.Button12Click(Sender: TObject); 
var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    call @label1 
    db $E8,$E8 
    jmp @label4 
  @label1: 
    pop eax 
    jmp @label2 
    db $E8,$E8 
  @label2: 
    add eax,2 
    jmp @label3 
    db $E8 
  @label3: 
    push eax 
    ret 
    db $E8 
  @label4: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end;

指令花

var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  asm 
    jo @label 
    jno @label 
    db $E8 
    @label: 
  end; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end; 

var 
  a,b:Integer; 
begin 
  a:=20;b:=10; 
  if a>b then 
    Messagebox(Handle,'a>b','info',MB_OK); 
end;

花

unit rsrDownMan; 
 
interface 
uses SysUtils, Classes, StrUtils, DateUtils, Windows, Forms, 
   Gauges, StdCtrls, 
   IDHTTP, IdFTP, IdComponent; 
{ 
自动下载组件 
by    renshouren 
mail  root@renshou.net 
QQ    114032666 
2009.05.25 
 
工作流程 
通过 DownStart 过程，取FURLList下载列表中的第一条作为当前URL(FCurURL) 
通过线程 THTTPGetHeadThread ，使用TIdHTTP 的HEAD方法，返回文件信息 
启动工作线程 THTTPDownThread ，下载数据 
 
工作时，可以通过 TDownWorkEvent 的workFileInfo参数获得正在下载文件的一些相关信息， 
该信息类应当于加入下载列表时加入，在TAFileDownEndEvent用户代码中释放该类 
 
2009.06.04 加入 FTP 下载，采用 PASV模式 
} 
Const 
   MAX_THREAD = 10; 
   FIRST_THREAD_SIZE  = 1024 * 100;//小于100K 的将使用单线程 
 
type 
  FTPWorkEndException = class (Exception); 
 
  TDownFileType       = (dfNorm, dfExe, dfList, dfMDB); 
  TDownErrorEvent     = procedure(Sender: TObject; const ErrMsg: string) of object; 
  TDownEventMode      = (deCreate, deConnected, deDisConnected, deWork, deWorkBegin, deWorkEnd, deDownEnd); 
  TDownWorkEvent      = procedure(Sender: TObject; const AWorkCount: Integer; workFileInfo{正在下载文件的一些附属信息}: TObject) of object; 
  TGetHTTPHeadEvent   = procedure(Sender: TObject; const ResponseText: string; Const ResponseCode: integer; var AutoDownNext: boolean) of object; 
  TAFileDownEndEvent  = procedure(Sender: TObject; stream: TMemoryStream; lastFileInfo{用户应该在响应此事件后释放本类}: TObject) of object; 
  TGetFTPHeadEvent    = procedure(Sender: TObject; Const CanResume: boolean; Size: int64; var AutoDownNext: boolean) of object; 
 
  TIdHTTPResponseInfo = record     //返回的HTTP信息 
      FCacheControl: String; 
      //FRawHeaders: TIdHeaderList; 
      FConnection: string; 
      FContentEncoding: string; 
      FContentLanguage: string; 
      FContentLength: Integer; 
      FContentRangeEnd: Cardinal; 
      FContentRangeStart: Cardinal; 
      FContentType: string; 
      FContentVersion: string; 
      //FCustomHeaders: TIdHeaderList; 
      FDate: TDateTime; 
      FExpires: TDateTime; 
      FLastModified: TDateTime; 
      FPragma: string; 
      FHasContentLength: Boolean; 
 
      FLocation :string; 
      FServer   :string; 
 
      FResponseText :string; 
      FResponseCode :Integer; 
      FResponseVersion :TIdHTTPProtocolVersion; 
  end; 
 
  TDownServerInfo = record 
     FHost  :string; 
     FPort  :Integer; 
     FUserName  :string; 
     FPassWord  :string; 
     FRemoteFile  :string;//文件相对URL 
  end; 
 
  TDownThreadInfo = record 
      nIndex  :Integer;//线程编号 
      URL :string; 
      nStart :Integer;//开始位置 
      nEnd  :Integer; //结束位置 
      nByteCount  :Integer;//下载块长度 
  end; 
 
 
    { 
    下载类 
    基类， 包含纯虚方法，因此不能直接创建其实例 
    procedure BeginThread; virtual; abstract;      //启动下载线程 
    } 
    TBaseDownMan = class (TComponent) 
    private 
       FThreadCount :integer; 
       MyThread :array [0..MAX_THREAD] of TThread;   //最大 MAX_THREAD 个 线程 
 
       FOnError :TDownErrorEvent;           //错误 
       FOnAFileEnd :TAFileDownEndEvent;           //一个文件完成 
       FOnAllDownEnd :TNotifyEvent;         //所有文件下载完成 
       FOnWork  :TDownWorkEvent;                //接收到数据 
 
       FStartTime :TDateTime;   //下载开始时间 
       FTotalFileCount :Integer;     //文件数 
       FCurFileCount  :Integer; //当前第几个 
       FCurFileSize :int64;   //当前文件大小 
       FDownTotalBytes :Int64; //所有文件已下载字节数 
       FTotalBytes  :Int64;     //所有下载任务需下载的字节数[由调用者作为参数提供] 
       FGaugeTotal, FGaugeCur : TGauge;  //进度条 
        
       FlbURL{显示当前下载文件的URL}, FlbSpeed{显示下载速度}, FlbFileCount: TLabel;   
       FCurURL  :string;     //当前正在下载的URL 
       FCurURLObject  :TObject; //当前下载文件的一些附加信息，有可能为NIL 
       FLocalFileName :string;        //根据URL得到的本地文件名 
       FNeedSec :Integer;//推测剩余时间(秒) 
 
 
       FDownServerInfo  :TDownServerInfo;         //服务器信息 
 
       FAutoSaveFile  :Boolean;                   //是否在最后一线程完成后自动保存为本地文件 
       FAThreadDefaultSize  :integer;//单个线程默认大小 
       FAverageSpeed :integer;   //平均速度 K/秒 
       FWorkingThreadCount :Integer;  //尚未完成下载任务的线程数，如果该值为0，则总下载任务完成 
 
       FThreadAWorkCount  :Integer;         //[当前文件]所有线程下载的字节数 
       FLastThreadAWorkCount  :Integer; 
 
       FThreadTotalCount  :Integer;     //总线程数 
       
       FStream  :TMemoryStream; 
       FFileType  :TDownFileType; 
 
       FURLList :TStringList;  //需要下载的URL列表 
 
       procedure SetTotalBytes (Value: int64); 
       procedure ResetGaugeTotal;              //解决Gauge.MaxValue 的Max 值太小的问题 
 
       function  GetFileNameByURL (URL: string): string; 
       function  RemoteFileToURL (rname: string): string; 
 
       procedure ThreadOnTerminate (Sender: TObject); 
       procedure IdHTTPOnRedirect(Sender: TObject; var dest: string; var NumRedirect: Integer; var Handled: boolean; var VMethod: TIdHTTPMethod); 
 
       procedure SetThreadCount (value: integer); 
       procedure DoError (ErrMsg: string); 
 
       procedure getHead; virtual; 
       procedure downNext; virtual; 
 
       procedure downData; virtual; 
       procedure BeginThread; virtual; abstract;      //启动下载线程 
       procedure GetDownServerInfo (Const URL: string ;var DSInfo: TDownServerInfo);{远程文件的相对路径} virtual; abstract;//从URL获得信息 
    protected 
       property  OnError: TDownErrorEvent read FOnError write FOnError; 
       property  OnAFileEnd: TAFileDownEndEvent read FOnAFileEnd write FOnAFileEnd; 
       property  OnAllDownEnd: TNotifyEvent read FOnAllDownEnd write FOnAllDownEnd; 
       property  OnWork: TDownWorkEvent read FOnWork write FOnWork; 
 
       property  GaugeTotal :TGauge read FGaugeTotal write FGaugeTotal; 
       property  GaugeCur :TGauge read FGaugeCur write FGaugeCur; 
       property  lbURL  :TLabel read FlbURL write FlbURL; 
       property  lbSpeed  :TLabel read FlbSpeed write FlbSpeed; 
       property  lbFileCount  :TLabel read FlbFileCount write FlbFileCount; 
       property  AverageSpeed  :integer read FAverageSpeed; 
       property  ThreadCount  :Integer read FThreadCount write SetThreadCount Default 5; 
       property  AutoSaveFile :Boolean read FAutoSaveFile write FAutoSaveFile Default True; 
    public 
       procedure downStart; virtual; 
       procedure downStop; virtual; 
       procedure downPause; virtual; 
 
 
       function  AddURL (URL: string): Integer; overload; 
       function  AddURL (URL: string; objFileInfo{由用户传入，所以必须由用户负责释放}: TObject): Integer; overload; 
       procedure AddURL (URLs :TStringList); overload; 
 
       procedure DoAFileEnd;  virtual; 
       procedure DoAllWorkEnd;  virtual; 
       procedure DoWork; virtual;             //工作线程接收到数据 
 
 
       property  LocalFileName : string read FLocalFileName; 
       property  DownTotalBytes :Int64 read FDownTotalBytes; 
       property  TotalBytes :Int64 read FTotalBytes write SetTotalBytes; 
       property  TotalFileCount :Integer read FTotalFileCount; 
       property  CurFileCount :Integer read FCurFIleCOunt; 
       property  FileType :TDownFIleType read FFileType write FFileType Default dfNorm; 
       property  StartTime:TDateTime read FStartTime; 
 
        
 
       Constructor Create(AOwner: TComponent); override; // 
       destructor  Destroy; override; 
    published 
 
 
 
end; 
 
   { 
    HTTP 下载类 
    先使用 Head 方法获得文件信息 
   } 
   THTTPDownMan = class (TBaseDownMan) 
   private 
      FHTTPResponseInfo  :TIdHTTPResponseInfo;   //根据HEAD方法返回的HTTP头 
      FRawHeaders :TStringList;                 //服务器响应的原始报头 
      FOnGetHead :TGetHTTPHeadEvent;            //HEAD方法成功 
      FNoThread  :Boolean;                     //如果是动态生成的文件，则不支持多线程 
 
      function  GetFileNameByRawHeaders (var FileName: string; Headers  :TStringList): boolean;  //重新设置保存文件名 
      function  Have_Accept_Ranges (Headers: TStringList): boolean;        //是否支持断点续传 
      procedure  GetDownServerInfo (Const URL: string ;var DSInfo: TDownServerInfo); override;//从URL获得信息 
      procedure DoGetHead;           //通过HEAD方法获得返回的文件及服务器信息 
      procedure getHead; override; 
 
       procedure BeginThread; override; 
   public 
      Constructor Create(AOwner: TComponent); override; // 
       destructor  Destroy; override; 
   published 
       property  OnError; 
       property  OnAFileEnd; 
       property  OnAllDownEnd; 
       property  OnWork; 
       property  OnGetHead: TGetHTTPHeadEvent read FOnGetHead write FOnGetHead; 
       property  HTTPResponseInfo :TIdHTTPResponseInfo read FHTTPResponseInfo; 
 
       property  GaugeTotal; 
       property  GaugeCur; 
       property  lbURL; 
       property  lbSpeed; 
       property  lbFileCount; 
       property  AverageSpeed; 
       property  ThreadCount; 
       property  AutoSaveFile; 
   end; 
 
   TFTPDownMan = class (TBaseDownMan) 
   private 
      FCurCanResume :Boolean; 
 
      FOnGetHead:TGetFTPHeadEvent; 
 
      procedure DoGetHead; 
      procedure getHead; override; 
 
      procedure BeginThread; override; 
      procedure  GetDownServerInfo (Const URL: string ;var DSInfo: TDownServerInfo); override;//从URL获得信息 
   public 
   published 
       property  OnError; 
       property  OnAFileEnd; 
       property  OnAllDownEnd; 
       property  OnWork; 
       property  OnGetHead:TGetFTPHeadEvent read FOnGetHead write FOnGetHead; 
       property  GaugeTotal; 
       property  GaugeCur; 
       property  lbURL; 
       property  lbSpeed; 
       property  lbFileCount; 
       property  AverageSpeed; 
       property  ThreadCount; 
       property  AutoSaveFile; 
   end; 
 
   THTTPGetHeadThread = class (TThread) 
   Private 
//      FURL  :string; 
      FErrMSG :string; 
      FRedirectURL  :string; 
//      FPort :SmallInt; 
      FDownMan  :THTTPDownMan; 
 
      FHTTPResponseInfo  :TIdHTTPResponseInfo; 
      FServerInfo :TDownServerInfo; 
 
      FRawHeaders :TStringList; 
 
      procedure SetResponseInfo; 
      procedure DoError; 
      procedure OnRedirect(Sender: TObject; var dest: string; var NumRedirect: Integer; var Handled: boolean; var VMethod: TIdHTTPMethod); 
      procedure DoRedirect; 
   protected 
      procedure Execute; override; 
   public 
      constructor create (downMan: THTTPDownMan); overload; 
 
   end; 
 
   TFTPGetHeadThread = class (TThread) 
   Private 
//      FURL  :string; 
      FErrMsg :string; 
      FPort :SmallInt; 
      FDownMan  :TFTPDownMan; 
      FCanResume  :Boolean; //是否支持断点续传 
 
      FServerInfo :TDownServerInfo; 
      FSize :Int64; 
 
      procedure SetResponseInfo; 
      procedure DoError; 
   protected 
      procedure Execute; override; 
   public 
      constructor create (downMan: TFTPDownMan); overload; 
 
   end; 
 
{ 
 HTTP下载线程类 
} 
  THTTPDownThread = class(TThread)  //文件下载线程类 
  private 
 
    FDownInfo :TDownThreadInfo;  //本线程下载信息 
    FStream :TMemoryStream; 
    FDownMan  :THTTPDownMan; 
 
//    FPort :SmallInt; 
    FServerInfo :TDownServerInfo; 
 
    FLastAWorkCount  :Integer; 
    FAWorkCount :integer; // 
    FAWorkCOuntMax  :Integer; 
    FDownEventMode  :TDownEventMode; 
 
 
 
    procedure IdHTTPConnected(Sender: TObject); 
    procedure IdHTTPDisConnected(Sender: TObject); 
    procedure IdHTTPWork(Sender: TObject; AWorkMode: TWorkMode; 
          const AWorkCount: Integer); 
    procedure IdHTTPWorkBegin(Sender: TObject; AWorkMode: TWorkMode; 
          const AWorkCountMax: Integer); 
    procedure IdHTTPWorkEnd(Sender: TObject; AWorkMode: TWorkMode); 
 
    procedure UpdateState; 
    procedure UpdateStream; 
  protected 
    procedure Execute; override; 
    function  DownLoadFile: boolean; //下载文件段 
 
  public 
    constructor create(downMan: THTTPDownMan;const downInfo: TDownThreadInfo); overload; 
 
 
  end; 
 
  TFTPDownThread = class (TThread) 
  private 
    FErrMsg :string; 
    FDownInfo :TDownThreadInfo;  //本线程下载信息 
    FStream :TMemoryStream; 
    FDownMan  :TFTPDownMan; 
    FServerInfo :TDownServerInfo; 
    FCanResume  :Boolean; 
 
    FLastAWorkCount  :Integer; 
    FAWorkCount :integer; // 
    FAWorkCOuntMax  :Integer; 
    FDownEventMode  :TDownEventMode; 
 
    procedure DoError; 
     
    procedure IdFTPConnected(Sender: TObject); 
    procedure IdFTPDisConnected(Sender: TObject); 
    procedure IdFTPWork(Sender: TObject; AWorkMode: TWorkMode; 
          const AWorkCount: Integer); 
    procedure IdFTPWorkBegin(Sender: TObject; AWorkMode: TWorkMode; 
          const AWorkCountMax: Integer); 
    procedure IdFTPWorkEnd(Sender: TObject; AWorkMode: TWorkMode); 
 
    procedure UpdateState; 
    procedure UpdateStream; 
  protected 
    procedure Execute; override; 
    function  DownLoadFile(): boolean; //下载文件段 
 
  public 
    constructor create(downMan: TFTPDownMan;const downInfo: TDownThreadInfo); overload; 
 
 
  end; 
 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin  
  RegisterComponents ('RSR', [ THTTPDownMan, TFTPDownMan ] ); 
end; 
 
{ TBaseDownMan } 
 
constructor TBaseDownMan.Create(AOwner: TComponent); 
begin 
   Inherited Create (AOwner); 
   FURLList := TStringList.Create; 
   FStream  := TMemoryStream.Create; 
   FThreadCount := 5; 
   FAutoSaveFile  := True; 
end; 
 
destructor TBaseDownMan.Destroy; 
begin 
   downStop; 
   FStream.Clear; 
   FStream.Free; 
   FURLList.Free; 
   inherited; 
end; 
 
function TBaseDownMan.GetFileNameByURL(URL: string): string; 
var i, nLen: integer; 
begin 
   result := ''; 
   nLen := Length (URL); 
   for i  := nLen downto 1 do begin 
      if URL[i] = '/' then break; 
      result  := URL[i] + result; 
   end; 
end; 
 
function TBaseDownMan.RemoteFileToURL(rname: string): string; 
var i, nLen: integer; s: string; 
begin 
   result := ''; 
   nLen := Length (rname); 
   for i  := 1 to nLen do begin 
      if rname[i] in ['!'..'@','A'..'Z', 'a'..'z'] then 
         result := result + rname[i] 
      else 
         result := result + '%' + Format ('%.2X', [Byte (rname[i])]); 
   end; 
end; 
 
procedure TBaseDownMan.ThreadOnTerminate(Sender: TObject); 
var i: integer; 
begin 
   for i  := low(MyThread) to High (MyThread) do begin 
      if Sender = MyThread[i] then begin 
         MyThread[i]  := nil; 
         break; 
      end; 
   end; 
end; 
 
procedure TBaseDownMan.DoAFileEnd; 
begin 
   if Assigned (FOnAFileEnd) then 
      //如果存在 FCurURLObject ，则应该在用户代码中手工释放 
      FOnAFileEnd (self, FStream, FCurURLObject); 
   if FURLList.Count > 1 then begin 
      FURLList.Delete(0); 
      downNext;    //继续下载其它文件 
   end else 
      DoAllWorkEnd; 
end; 
 
 
 
procedure TBaseDownMan.IdHTTPOnRedirect(Sender: TObject; var dest: string; 
  var NumRedirect: Integer; var Handled: boolean; 
  var VMethod: TIdHTTPMethod); 
begin 
   FLocalFileName := dest; 
end; 
 
function TBaseDownMan.AddURL(URL: string): Integer; 
begin 
   if FURLList.IndexOf(URL) < 0 then 
      FURLList.Add(URL); 
   result := FURLList.Count; 
end; 
 
procedure TBaseDownMan.AddURL(URLs: TStringList); 
begin 
   FURLList.AddStrings(URLs); 
end; 
 
 
 
procedure TBaseDownMan.DoAllWorkEnd; 
begin 
   if Assigned (FOnAllDownEnd) then 
      FOnAllDownEnd (self); 
 
   FURLList.Clear;  //清除下载任务列表 
   
end; 
 
procedure TBaseDownMan.DoWork; 
Var 
  S: String; 
  TotalTime: TDateTime; 
  H, M, Sec, MS: Word; 
  DLTime: Double;     //下载总秒数 
begin 
 
   //下载总字节数 
   FDownTotalBytes  := FDownTotalBytes + FThreadAWorkCount - FLastThreadAWorkCount; 
   FLastThreadAWorkCount  := FThreadAWorkCount; 
 
   FCurFileCount  := FTotalFileCount - FURLList.Count + 1; 
 
 
    TotalTime :=  Now - FStartTime; 
    DecodeTime(TotalTime, H, M, Sec, MS); 
    Sec := Sec + M * 60 + H * 3600; 
    DLTime := Sec + MS / 1000; 
    if DLTime > 0 then 
       
       FAverageSpeed  := ROund (FThreadAWorkCount / DLTime); 
 
    if FAverageSpeed > 0 then 
       Sec  := Trunc ((FCurFileSize - FThreadAWorkCount) / FAverageSpeed ); 
 
    if (FAverageSpeed > 0) and Assigned (FlbSpeed) then begin 
       S := Format('%d小时%d分%d秒', [Sec div 3600, (Sec div 60) mod 60, Sec mod 60]); 
       S := '剩余时间：' + S; 
       S := FormatFloat('0.00 KB/秒', FAverageSpeed/ 1024) + '; ' + S; 
 
       FlbSpeed.Caption := S; 
    end; 
 
 
   if Assigned (FlbURL) then 
      FlbURL.Caption  := FLocalFileName + ' 来自 ' + FDownServerInfo.FHost; 
 
    if Assigned (FGaugeCur) then 
       FGaugeCur.Progress := FThreadAWorkCount; 
 
    if Assigned (FlbFileCount) then 
       FlbFileCount.Caption := FOrmat ('%d/%d', [FTotalFileCOunt, FCurFileCount]); 
 
    ResetGaugeTotal;//设置总下载 
 
 
    if Assigned (FOnWork) then 
       FOnWork (self, FThreadAWorkCount, FCurURLObject); 
 
    Application.ProcessMessages;   
end; 
 
procedure TBaseDownMan.SetThreadCount(value: integer); 
begin 
   if value > MAX_THREAD then value := MAX_THREAD; 
   if value <> FThreadCount then 
      FThreadCount  := value; 
 
end; 
 
procedure TBaseDownMan.downStart; 
var nLen: integer; downInfo: TDownThreadInfo; 
begin 
   downStop; 
   FDownTotalBytes  := 0;     //归零下载总字节 
   FTotalFileCount  := FURLList.Count; 
   FCurFileCount  := 0; 
   FCurFileSize := 0; 
   if Assigned (FGaugeCur) then 
      FGaugeCur.Progress  := 0; 
   if Assigned (FGaugeTotal) then 
      FGaugeTotal.Progress  := 0; 
   if Assigned (lbURL) then 
      lbURL.Caption := ''; 
   if Assigned (lbSpeed) then 
      lbSpeed.Caption := ''; 
   downNext; 
end; 
 
 
 
procedure TBaseDownMan.downNext; 
begin 
   if FURLList.Count < 1 then exit; 
   FCurURL  := FURLList[0]; 
   GetDownServerInfo (FCurURL, FDownServerInfo);      // 
   FCurURLObject  := FURLList.Objects[0]; 
 
   FCurFileSize := 0; 
   if Assigned (FGaugeCur) then 
      FGaugeCur.Progress  := 0; 
    
   if Assigned (lbURL) then 
      lbURL.Caption := ''; 
   if Assigned (lbSpeed) then 
      lbSpeed.Caption := ''; 
 
   getHead; 
end; 
 
 
 
procedure TBaseDownMan.downData; 
var i, nLen: integer; downInfo: TDownThreadInfo; 
begin 
      FStream.SetSize(FCurFileSize); 
      //强制将当前文件进度条设置为0% 
      if Assigned (FGaugeCur) then begin 
 
         FGaugeCur.MaxValue := FCurFileSize; 
         FGaugeCur.Progress  := 0; 
      end; 
 
      nLen  := FCurFileSize div FThreadTotalCount; 
      FAThreadDefaultSize := nLen; 
 
      FStartTime  := NOW;  //数据线程开始 
      BeginThread; // 
end; 
 
procedure TBaseDownMan.SetTotalBytes(Value: int64); 
begin 
   if value <> FTotalBytes then begin 
      FTotalBytes := value; 
      ResetGaugeTotal; 
   end; 
end; 
 
procedure TBaseDownMan.ResetGaugeTotal; 
var n :Integer; 
begin 
  if FTotalBytes = 0 then exit; 
  if not Assigned (FGaugeTotal) then exit; 
  if FTotalBytes > $7FFFFFFF then begin 
     n  := ROund (FTotalBytes / $7FFFFFF); 
     FGaugeTotal.Progress := Round (FDownTotalBytes / n); 
  end else begin 
     FGaugeTotal.MaxValue := FTotalBytes; 
     FGaugeTotal.Progress := FDownTotalBytes; 
  end; 
end; 
 
procedure TBaseDownMan.downStop; 
var i: integer; 
begin 
   for i  := low(MyThread) to High(MyThread) do begin 
      if Assigned (MyThread[i]) then begin 
         TerminateThread (MyThread[i].Handle, 0); 
         //MyThread[i].Suspend; 
         MyThread[i]  := nil; 
      end; 
   end; 
 
end; 
 
procedure TBaseDownMan.downPause; 
var i: integer; 
begin 
   for i  := low(MyThread) to High(MyThread) do begin 
      if Assigned (MyThread[i]) then begin 
         if MyThread[i].Suspended then 
            MyThread[i].Resume 
         else 
            MyThread[i].Suspend; 
         //MyThread[i]  := nil; 
      end; 
   end; 
 
end; 
 
function TBaseDownMan.AddURL(URL: string; objFileInfo: TObject): Integer; 
begin 
   if FURLList.IndexOf(URL) < 0 then 
      FURLList.AddObject(URL, objFileInfo); 
   result := FURLList.Count; 
end; 
 
procedure TBaseDownMan.getHead; 
begin 
   if Assigned (FlbURL) then 
      FlbURL.Caption  := FCurURL; 
 
   FLocalFileName  := GetFileNameByURL (FCurURL); 
end; 
 
procedure TBaseDownMan.DoError(ErrMsg: string); 
begin 
   if Assigned (FOnError) then 
      FOnError (self, ErrMsg); 
end; 
 
{ THTTPDownThread } 
 
constructor THTTPDownThread.create(downMan: THTTPDownMan;const downInfo: TDownThreadInfo); 
begin 
   inherited create(true); 
   FreeOnTerminate := true; 
   FLastAWorkCount  := 0; 
 
   FDownEventMode := deCreate; 
 
   FDownInfo  := downinfo; 
   FDownMan := downMan; 
   FServerInfo  := FDownMan.FDownServerInfo; 
    
end; 
 
 
function THTTPDownThread.DownLoadFile: boolean; 
var FHttp: TIdHTTP; 
    //stream  :TMemoryStream; 
begin 
   RESULT := False; 
   FHttp := TIdHTTP.Create(nil); 
   try 
 
      //FHttp.OnConnected := IdHTTPConnected ; 
      //FHttp.OnDisconnected  := IdHTTPDisConnected; 
      FHttp.OnWork  := IdHTTPWork; 
      FHttp.OnWorkBegin := IdHTTPWorkBegin; 
      FHttp.OnWorkEnd := IdHTTPWorkEnd; 
      FHttp.Host  := FServerInfo.FHost; 
      FHttp.Port  := FServerInfo.FPort; 
 
      Fstream  := TMemoryStream.Create; 
      try 
         FHttp.Request.ContentRangeStart := FDownInfo.nStart; 
         FHttp.Request.ContentRangeEnd := FDownInfo.nEnd; 
 
         FHttp.Get(FServerInfo.FRemoteFile, FStream); 
         Synchronize (UpdateStream );   //保存数据 
          
         result := True; 
      finally 
         begin 
            Fstream.Clear; 
            Fstream.Free; 
 
         end; 
      end; 
       
   finally 
      begin 
         FreeAndNil (FHTTP); 
      end; 
   end; 
end; 
 
procedure THTTPDownThread.Execute; 
begin 
  DownLoadFile ; 
  
end; 
 
procedure THTTPDownThread.IdHTTPConnected(Sender: TObject); 
begin 
   FDownEventMode := deConnected; 
   Synchronize ( UpdateState ); 
end; 
 
procedure THTTPDownThread.IdHTTPDisConnected(Sender: TObject); 
begin 
   FDownEventMode := deDisConnected; 
   Synchronize ( UpdateState ); 
end; 
 
procedure THTTPDownThread.IdHTTPWork(Sender: TObject; AWorkMode: TWorkMode; 
  const AWorkCount: Integer); 
begin 
   FDownEventMode := deWork; 
   FAWorkCount  := AWOrkCount; 
   Synchronize ( UpdateState ); 
end; 
 
procedure THTTPDownThread.IdHTTPWorkBegin(Sender: TObject; 
  AWorkMode: TWorkMode; const AWorkCountMax: Integer); 
begin 
   FDownEventMode := deWorkBegin; 
   FAWorkCountMax := AWorkCountMax; 
 
   Synchronize ( UpdateState ); 
end; 
 
procedure THTTPDownThread.IdHTTPWorkEnd(Sender: TObject; AWorkMode: TWorkMode); 
begin 
   FDownEventMode := deWorkEnd; 
   FAWorkCount  := FDownInfo.nByteCount; 
   Synchronize ( UpdateState ); 
end; 
 
procedure THTTPDownThread.UpdateState; 
begin 
   if FDownEventMode = deWork then begin 
      FDownMan.FThreadAWorkCount := FDownMan.FThreadAWorkCount + FAWorkCount - FLastAWorkCount; 
      FLastAWorkCount := FAWorkCount; 
      FDownMan.DoWork; 
   end; 
 
end; 
 
procedure THTTPDownThread.UpdateStream; 
begin 
   if Assigned (FStream) then begin 
      FdownMan.Fstream.Seek(FDownInfo.nStart, soBeginning); 
      Fstream.Position := 0; 
      FdownMan.Fstream.Write(FStream.Memory^, FStream.Size); 
 
      Dec (Fdownman.FWorkingThreadCount); 
      if FDownMan.FWorkingThreadCount = 0 then begin 
         if FDownMan.AutoSaveFile then 
            TMemoryStream (FdownMan.Fstream).SaveToFile(FDownMan.FLocalFileName); 
         FDownEventMode := deDownEnd; 
         FDownMan.DoAFileEnd; 
      end; 
   end; 
end; 
 
{ THTTPGetHeadThread } 
 
constructor THTTPGetHeadThread.create(downMan: THTTPDownMan); 
begin 
   inherited create(true); 
   FreeOnTerminate := true; 
   FDownMan := downMan; 
   FServerInfo  := FDownMan.FDownServerInfo; 
end; 
 
procedure THTTPGetHeadThread.DoError; 
begin 
   FDownMan.DoError (FErrMsg); 
end; 
 
procedure THTTPGetHeadThread.DoRedirect; 
begin 
   FDownMan.FCurURL  := FRedirectURL; 
   FDOwnMan.FLocalFileName  := FRedirectURL; 
end; 
 
procedure THTTPGetHeadThread.Execute; 
var FHTTP: TIdHTTP; 
begin 
  //inherited; 
   FHTTP  := TIdHTTP.Create(nil); 
   try 
      try 
         FHTTP.ReadTimeout  := 5000; 
         FHTTP.HandleRedirects  := True; 
         FHTTP.OnRedirect := OnRedirect; 
         FHTTP.Host := FServerInfo.FHost; 
         FHTTP.Port := FServerInfo.FPort; 
 
         FHTTP.Head(FServerInfo.FRemoteFile); 
          
      except on E:Exception do 
         begin 
            FErrMsg := E.Message; 
            Synchronize (DoError); 
         end; 
      end; 
 
      FServerInfo.FHost := FHTTP.Host; 
      FServerInfo.FPort := FHTTP.Port; 
 
       
      With FHTTP.Response do begin 
         FHTTPResponseInfo.FCacheControl := CacheControl; 
         FHTTPResponseInfo.FConnection  := Connection; 
         FHTTPResponseInfo.FContentEncoding := ContentEncoding; 
         FHTTPResponseInfo.FContentLanguage := ContentLanguage; 
         FHTTPResponseInfo.FContentLength := ContentLength; 
         FHTTPResponseInfo.FContentType := ContentType; 
         FHTTPResponseInfo.FContentVersion  := ContentVersion; 
         FHTTPResponseInfo.FDate  := Date; 
         FHTTPResponseInfo.FExpires := Expires; 
         FHTTPResponseInfo.FLastModified  := LastModified; 
         FHTTPResponseInfo.FPragma  := Pragma; 
         FHTTPResponseInfo.FHasContentLength  := HasContentLength; 
         FHTTPResponseInfo.FLocation  := Location; 
         FHTTPResponseInfo.FServer  := Server; 
         FHTTPResponseInfo.FResponseText  := ResponseText; 
         FHTTPResponseInfo.FResponseCode  := ResponseCode; 
         FHTTPResponseInfo.FResponseVersion := ResponseVersion; 
      end; 
 
      FRawHeaders := TStringList.Create; 
      FRawHeaders.AddStrings(FHTTP.Response.RawHeaders); 
      Synchronize (SetResponseInfo); 
      FRawHeaders.Free; 
   finally FreeAndNil (FHTTP) end; 
end; 
 
procedure THTTPGetHeadThread.OnRedirect(Sender: TObject; var dest: string; 
  var NumRedirect: Integer; var Handled: boolean; 
  var VMethod: TIdHTTPMethod); 
begin 
   FRedirectURL := dest; 
   Synchronize (DoRedirect); 
end; 
 
procedure THTTPGetHeadThread.SetResponseInfo; 
begin 
   FDownMan.FHTTPResponseInfo := FHTTPResponseInfo; 
   FDownMan.FDownServerInfo := FServerInfo; 
   FDownMan.FRawHeaders.Assign(FRawHeaders); 
   FDownMan.DoGetHead; 
end; 
 
{ THTTPDownMan } 
 
procedure THTTPDownMan.BeginThread; 
var i: integer; 
    downinfo  :TDownThreadInfo; 
begin 
   if FNoThread then begin 
      FThreadTotalCount  := 1; 
      FWorkingThreadCount := FThreadTotalCount; 
   end; 
    
  for i := 1 to FThreadTotalCount do begin 
         downinfo.nStart  := FAThreadDefaultSize  * (i - 1); 
         if i < FThreadTotalCount then 
            downinfo.nEnd := FAThreadDefaultSize * i - 1 
         else 
            downinfo.nEnd := FCurFileSize - 1; 
 
         downinfo.URL := FCurURL; 
         downinfo.nIndex  := i; 
         downinfo.nByteCount  := downinfo.nEnd - downinfo.nStart + 1; 
         MyThread[i-1]  := THTTPDownThread.create( self, downinfo); 
         MyThread[i-1].OnTerminate  := ThreadOnTerminate; 
         MyThread[i-1].Resume; 
  end; 
 
end; 
 
constructor THTTPDownMan.Create(AOwner: TComponent); 
begin 
   Inherited Create (AOwner); 
   FRawHeaders  := TStringList.Create; 
 
end; 
 
destructor THTTPDownMan.Destroy; 
begin 
   FRawHeaders.Free; 
  inherited; 
end; 
 
procedure THTTPDownMan.DoGetHead; 
var autoDownNext: boolean; 
begin 
   autoDownNext := True; //默认发生错误时继续下载下一个 
   FCurFileSize := FHTTPResponseInfo.FContentLength; //已经从GetHeadThread获得文件大小 
   if Assigned (FGaugeCur) then begin 
      if  FCurFileSize >= 0 then 
         FGaugeCur.MaxValue  := FCurFileSize; 
      FGaugeCur.Progress  := 0; 
   end; 
 
   FThreadAWorkCount  := 0; 
   FLastThreadAWorkCount  := 0; 
 
   GetFileNameByRawHeaders (FLocalFileName, FRawHeaders); 
 
   if (FCurFileSize > FIRST_THREAD_SIZE) and (Have_Accept_Ranges (FRawHeaders)) then 
       FThreadTotalCount  := FThreadCount 
   else 
       FThreadTotalCount  := 1; 
 
   //设置未下载完成线程数 
   FWorkingThreadCount := FThreadTotalCount; 
 
   if Assigned (FOnGetHead) then 
      FOnGetHead (self, FHTTPResponseInfo.FResponseText, FHTTPResponseInfo.FResponseCode, autoDownNext); 
 
   if Pos ('OK', UpperCase (FHTTPResponseInfo.FResponseText)) > 0 then begin 
      //获得文件信息后即开始下载 
      downData; 
   end else begin 
      if autoDownNext then 
 
         DoAFileEnd; 
   end; 
 
 
end; 
 
procedure THTTPDownMan.GetDownServerInfo(const URL: string; 
  var DSInfo: TDownServerInfo); 
var s, shost, suser, spwd, sport: string; 
    n, n2: integer; 
begin 
   //http://IP地址:端口号/文件地址 
   DSInfo.FRemoteFile := ''; 
   s  := Trim (URL); 
   if Pos ('HTTP://', UpperCase (s)) = 1 then 
      delete (s, 1, 7); 
 
   shost  := s; 
   n  := pos ('/', shost);   //第一个/前面为host 
   if n > 0 then begin 
      DSInfo.FRemoteFile  := copy (shost, n, length (shost) - n + 1); 
      delete (shost, n, length (shost) - n + 1); 
   end; 
 
   suser  := ''; 
   spwd := ''; 
 
   sport  := '80'; 
   n  := pos (':', shost); 
   if n > 0 then begin 
      sport := copy (shost, n + 1, length (shost) - n); 
      delete (shost, n, length (shost) - n + 1); 
   end; 
 
   DSInfo.FHost := shost; 
   DSInfo.FPort := StrToIntDef (sport, 80); 
   DSInfo.FUserName := suser; 
   DSInfo.FPassWord := spwd; 
end; 
 
function THTTPDownMan.GetFileNameByRawHeaders(var FileName: string; Headers: TStringList): boolean; 
var s : string;      //Content-Disposition: attachment; filename="fname.ext" 
    nPos, nLen, i:Integer; 
begin 
   result := False; 
   s  := ''; 
   for i  := 0 to Headers.Count - 1 do begin 
      if Pos (UpperCase ('Content-Disposition'), UpperCase (Headers.Strings[i])) > 0 then begin 
         s  := Headers.Strings[i]; 
         break; 
      end; 
   end; 
 
   if s = '' then exit; 
 
   nPos := Pos ('=', s); 
   if nPos > 1 then begin 
      delete (s, 1, nPos); 
      s := Trim (s); 
      if s = '' then exit; 
 
      if s[1] = '"' then begin 
         nLen := length (s); 
         if s[nLen] <> '"' then exit; 
         delete (s, 1, 1); 
         delete (s, nLen - 1, 1); 
         FileName := s; 
      end else 
         FIleName := s; 
 
      result  := True; 
   end; 
end; 
 
procedure THTTPDownMan.getHead; 
var aThread: THTTPGetHeadThread; 
begin 
   Inherited; 
   aThread  := THTTPGetHeadThread.create(Self); 
   aThread.Resume; 
end; 
 
function THTTPDownMan.Have_Accept_Ranges(Headers: TStringList): boolean; 
var s: string; 
    i :Integer; 
begin 
   result := False; 
   for i  := 0 to Headers.Count - 1 do begin 
      s := UpperCase (Headers[i]); 
      if Pos (UpperCase ('Accept-Ranges'), s) > 0 then begin 
         result := True; 
         break; 
      end; 
   end; 
end; 
 
{ TFTPGetHeadThread } 
 
constructor TFTPGetHeadThread.create(downMan: TFTPDownMan); 
begin 
   inherited create(true); 
   FreeOnTerminate := true; 
   FCanResume := False; 
   FDownMan := downMan; 
   FServerInfo  := FDownMan.FDownServerInfo; 
end; 
 
procedure TFTPGetHeadThread.DoError; 
begin 
   FDownMan.DoError(FErrMsg); 
end; 
 
procedure TFTPGetHeadThread.Execute; 
var FFTP: TIdFTP; 
begin 
  //inherited; 
   FFTP  := TIdFTP.Create(nil); 
   try 
      try 
         FFTP.ReadTimeout  := 5000; 
         FFTP.Host  := FServerInfo.FHost; 
         FFTP.Port  := FServerInfo.FPort; 
         FFTP.Username  := FServerInfo.FUserName; 
         FFTP.Password  := FServerInfo.FPassWord; 
 
         FSize  := -1; 
         FFTP.Connect(); 
         FCanResume := FFTP.CanResume; 
 
         FSize := FFTP.Size(FServerInfo.FRemoteFile); 
      except on E:Exception do 
         begin 
            FErrMsg := E.Message; 
            Synchronize (DoError); 
         end; 
      end; 
 
 
      Synchronize (SetResponseInfo); 
   finally FreeAndNil (FFTP) end; 
end; 
 
procedure TFTPGetHeadThread.SetResponseInfo; 
begin 
   FDownMan.FCurFileSize  := FSize; 
   FDownMan.FCurCanResume := FCanResume; 
   FDownMan.DoGetHead; 
end; 
 
{ TFTPDownMan } 
 
procedure TFTPDownMan.BeginThread; 
var i: integer; 
    downinfo  :TDownThreadInfo; 
begin 
   FWorkingThreadCount := FThreadTotalCount; 
 
  for i := 1 to FThreadTotalCount do begin 
         downinfo.nStart  := FAThreadDefaultSize  * (i - 1); 
         if i < FThreadTotalCount then 
            downinfo.nEnd := FAThreadDefaultSize * i - 1 
         else 
            downinfo.nEnd := FCurFileSize - 1; 
 
         downinfo.URL := FCurURL; 
         downinfo.nIndex  := i; 
         downinfo.nByteCount  := downinfo.nEnd - downinfo.nStart + 1; 
         MyThread[i-1]  := TFTPDownThread.create( self, downinfo); 
         MyThread[i-1].OnTerminate  := ThreadOnTerminate; 
         MyThread[i-1].Resume; 
  end; 
 
end; 
 
procedure TFTPDownMan.DoGetHead; 
var autoDownNext: boolean; 
begin 
   autoDownNext := True; //默认发生错误时继续下载下一个 
   //FCurFileSize 已经从GetHeadThread获得文件大小 
 
   if Assigned (FGaugeCur) then begin 
      if  FCurFileSize >= 0 then 
         FGaugeCur.MaxValue  := FCurFileSize; 
      FGaugeCur.Progress  := 0; 
   end; 
 
   FThreadAWorkCount  := 0; 
   FLastThreadAWorkCount  := 0; 
 
   if (FCurFileSize > FIRST_THREAD_SIZE) and FCurCanResume then 
       FThreadTotalCount  := FThreadCount 
   else 
       FThreadTotalCount  := 1; 
 
   if Assigned (FOnGetHead) then 
      FOnGetHead (self, FCurCanResume, FCurFileSize, autoDownNext); 
 
   if FCurFileSize <> -1 then 
      //获得文件信息后即开始下载 
      downData 
   else begin 
      if autoDownNext then 
 
         DoAFileEnd; 
   end; 
 
 
end; 
 
procedure TFTPDownMan.GetDownServerInfo (Const URL: string ;var DSInfo: TDownServerInfo); 
var s, shost, suser, spwd, sport: string; 
    n, n2: integer; 
begin 
   //ftp://账号:密码@IP地址:端口号 
   DSInfo.FRemoteFile := '/'; 
   s  := Trim (URL); 
   if Pos ('FTP://', UpperCase (s)) = 1 then 
      delete (s, 1, 6); 
 
   shost  := s; 
   n  := pos ('/', shost);   //第一个/前面为host 
   if n > 0 then begin 
      DSInfo.FRemoteFile  := copy (shost, n , length (shost) - n + 1); 
      delete (shost, n, length (shost) - n + 1); 
   end; 
 
   suser  := 'Anonymous'; 
   spwd := 'root@renshou.net'; 
   n  := pos ('@', shost); 
   if n > 0 then begin 
      n2  := pos (':', shost); 
      if (n2 > 0) and (n2 < n) then begin 
         suser := copy (shost, 1, n2 - 1); 
         spwd := copy (shost, n2 + 1, n - n2 - 1); 
      end; 
      delete (shost, 1, n); 
   end; 
 
   sport  := '21'; 
   n  := pos (':', shost); 
   if n > 0 then begin 
      sport := copy (shost, n + 1, length (shost) - n); 
      delete (shost, n, length (shost) - n + 1); 
   end; 
 
   DSInfo.FHost := shost; 
   DSInfo.FPort := StrToIntDef (sport, 21); 
   DSInfo.FUserName := suser; 
   DSInfo.FPassWord := spwd; 
end; 
 
procedure TFTPDownMan.getHead; 
var aThread: TFTPGetHeadThread; 
begin 
   Inherited; 
    
   aThread  := TFTPGetHeadThread.Create(Self); 
   aThread.Resume; 
end; 
 
{ TFTPDownThread } 
 
constructor TFTPDownThread.create(downMan: TFTPDownMan; 
  const downInfo: TDownThreadInfo); 
begin 
   inherited create(true); 
   FreeOnTerminate := true; 
   FLastAWorkCount  := 0; 
 
   FDownEventMode := deCreate; 
 
   FDownInfo  := downinfo; 
   FDownMan := downMan; 
   FServerInfo  := FDownMan.FDownServerInfo; 
   FCanResume := FDownMan.FCurCanResume; 
 
end; 
 
procedure TFTPDownThread.DoError; 
begin 
   FDownMan.DoError(FErrMsg); 
end; 
 
function TFTPDownThread.DownLoadFile(): boolean; 
var FTP: TIdFTP; 
begin 
   result := False; 
   FTP  := TIdFTP.Create(nil); 
   try 
      Fstream  := TMemoryStream.Create; 
      FTP.ReadTimeout  := 5000; 
      FTP.Host  := FServerInfo.FHost; 
      FTP.Port  := FServerInfo.FPort; 
      FTP.Username  := FServerInfo.FUserName; 
      FTP.Password  := FServerInfo.FPassWord; 
      FTP.OnConnected := IdFTPConnected; 
      FTP.OnDisconnected  := IdFTPDisConnected; 
      FTP.OnWork  := IdFTPWOrk; 
      FTP.OnWorkBegin := IdFTPWorkBegin; 
      FTP.OnWorkEnd := IdFTPWorkEnd; 
 
      try 
 
         FTP.Connect(); 
         //如果使用 Passive 模式，则工作正常 
         FTP.Passive := True; 
         if FCanResume then begin 
            //设置stream的大小为目标文件总大小 
            FStream.SetSize(FDownMan.FCurFileSize); 
            //为符合IdFTP的续传函数参数要求，设置Stream的偏移 
            FStream.Position  := FDownInfo.nStart; 
            try 
               //使用断点续传方式 
               FTP.Get(FServerInfo.FRemoteFile, FStream, True); 
               //读到指定位置时而触发的异常将忽略 
            except on E:FTPWorkEndException do 
            end; 
         end else 
            FTP.Get(FServerInfo.FRemoteFile, FStream); 
         Synchronize (UpdateStream );   //保存数据 
         result  := True; 
      except on E:Exception do 
         begin 
            FErrMsg := E.Message; 
            Synchronize (DoError); 
            FStream.Clear; 
            FStream.Free; 
         end; 
      end; 
   finally FreeAndNil (FTP) end; 
end; 
 
procedure TFTPDownThread.Execute; 
begin 
   DownLoadFile (); 
end; 
 
procedure TFTPDownThread.IdFTPConnected(Sender: TObject); 
begin 
   FDownEventMode := deConnected; 
   Synchronize ( UpdateState ); 
end; 
 
procedure TFTPDownThread.IdFTPDisConnected(Sender: TObject); 
begin 
   FDownEventMode := deDisConnected; 
   Synchronize ( UpdateState ); 
end; 
 
procedure TFTPDownThread.IdFTPWork(Sender: TObject; AWorkMode: TWorkMode; 
  const AWorkCount: Integer); 
begin 
   FDownEventMode := deWork; 
   FAWorkCount  := AWOrkCount; 
   if FAWorkCount >= FDownInfo.nByteCount then begin 
      //下面2句将由 WorkEnd 时执行 
      //FAWorkCount := FDownInfo.nByteCount; 
      //Synchronize ( UpdateState ); 
      raise FTPWorkEndException.Create ('a ftp thread down end.') ; 
      exit; 
   end; 
   Synchronize ( UpdateState ); 
end; 
 
procedure TFTPDownThread.IdFTPWorkBegin(Sender: TObject; 
  AWorkMode: TWorkMode; const AWorkCountMax: Integer); 
begin 
   FDownEventMode := deWorkBegin; 
   FAWorkCountMax := AWorkCountMax; 
 
   Synchronize ( UpdateState ); 
end; 
 
procedure TFTPDownThread.IdFTPWorkEnd(Sender: TObject; 
  AWorkMode: TWorkMode); 
begin 
   FDownEventMode := deWorkEnd; 
   FAWorkCount := FDownInfo.nByteCount; 
   Synchronize ( UpdateState ); 
end; 
 
procedure TFTPDownThread.UpdateState; 
begin 
   if FDownEventMode in [deWork, deWorkEnd] then begin 
      FDownMan.FThreadAWorkCount := FDownMan.FThreadAWorkCount + FAWorkCount - FLastAWorkCount; 
      FLastAWorkCount := FAWorkCount; 
      FDownMan.DoWork; 
   end; 
 
end; 
 
procedure TFTPDownThread.UpdateStream; 
begin 
   if Assigned (FStream) then begin 
      FdownMan.Fstream.Seek(FDownInfo.nStart, soBeginning); 
      //Fstream.Position := 0; 
      FdownMan.Fstream.Write(PLongWord (longword (FStream.Memory) + FDownInfo.nStart)^, FDownInfo.nByteCount); 
 
      //递减未完成下载的线程计数器 
      Dec (Fdownman.FWorkingThreadCount); 
 
      if FDownMan.FWorkingThreadCount = 0 then begin 
         if FDownMan.AutoSaveFile then 
            TMemoryStream (FdownMan.Fstream).SaveToFile(FDownMan.FLocalFileName); 
         FDownEventMode := deDownEnd; 
         FDownMan.DoAFileEnd; 
      end; 
   end; 
end; 
 
end.

indy 下载 http ftp

unit uMain; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, ExtCtrls, StdCtrls, ComCtrls, Buttons, Spin; 
 
type 
  TMain = class(TForm) 
    GroupBox1: TGroupBox; 
    lbox: TListBox; 
    Panel1: TPanel; 
    StatusBar1: TStatusBar; 
    GroupBox2: TGroupBox; 
    btnstartMonitor: TBitBtn; 
    btnStopMonitor: TBitBtn; 
    GroupBox3: TGroupBox; 
    GroupBox4: TGroupBox; 
    Label3: TLabel; 
    Label4: TLabel; 
    btnCreate: TBitBtn; 
    edtName: TEdit; 
    Label5: TLabel; 
    Label6: TLabel; 
    edtRetry: TSpinEdit; 
    GroupBox5: TGroupBox; 
    Label8: TLabel; 
    edtSource: TEdit; 
    edtUse: TEdit; 
    Label9: TLabel; 
    lvInfo: TListView; 
    Splitter1: TSplitter; 
    edtWaitTime: TSpinEdit; 
    Label1: TLabel; 
    Edit1: TEdit; 
    Label2: TLabel; 
    Label7: TLabel; 
    edtTimes: TSpinEdit; 
    Label10: TLabel; 
    CheckBox1: TCheckBox; 
    Label11: TLabel; 
    procedure btnstartMonitorClick(Sender: TObject); 
    procedure btnStopMonitorClick(Sender: TObject); 
    procedure btnCreateClick(Sender: TObject); 
  private 
    { Private declarations } 
  public 
    isMonitor: boolean; //is monitor the status ,is false didn't display the statu information 
    procedure AddInfoTolvinfo(index: integer; s: string); 
    function GetInfoFromlvInfo(index: integer): string; 
    procedure AddInfo(s: string); 
 
    { Public declarations } 
  end; 
 
  TDemoProcedure = class(TThread) 
  public 
    ListIndex: integer; 
    strName: string; 
    WaitTime, RetryTime, Times: Integer; 
    isWantSource: boolean; //申请资源标志 
    isDonotWantSource: boolean; //释放资源标志 
    constructor Create(); 
  private 
    { Private declarations } 
  protected 
    procedure Execute; override; 
    procedure WantSource; 
    procedure Wantsourceok; 
    procedure donWantSource; 
    procedure donWantsourceOK; 
    procedure EndThisRun; 
    procedure ShowError; 
    procedure ShowErrorEx; //释放资源被锁定，强制释放以防死锁 
  end; 
 
const 
  sRun = '运行状态'; 
  sWait = '申请资源'; 
  sWaitOk = '申请资源成功，进行使用期'; 
  sExit = '申请释放资源'; 
  sExitOk = '释放资源ok'; 
var 
 
  Main: TMain; 
 
implementation 
 
{$R *.dfm} 
 
procedure TMain.btnstartMonitorClick(Sender: TObject); 
begin 
  isMonitor := true; 
  btnStartMonitor.Enabled := false; 
  btnStopMonitor.Enabled := true; 
end; 
 
procedure TMain.btnStopMonitorClick(Sender: TObject); 
begin 
  isMonitor := false; 
  btnStartMonitor.Enabled := true; 
  btnStopMonitor.Enabled := false; 
end; 
 
procedure TMain.btnCreateClick(Sender: TObject); 
var 
  strName: string; 
  waitTime, Retry, Times: integer; 
  p: TListitem; 
  isMore: boolean; //判断该进程是否已存在 
  i: integer; 
  DemoProcedure: TDemoProcedure; 
begin 
  strName := Trim(edtName.Text); 
  waitTime := edtWaitTime.Value; 
  Retry := edtRetry.Value; 
  Times := edtTimes.Value; 
 
  if Trim(edtName.Text) = '' then 
  begin ShowMessage('模拟进程的名称必须输入，随便输'); edtName.SetFocus; exit; end; 
  if ((WaitTime <= 0) or (Retry <= 0)) then 
  begin ShowMessage('时间是不能设为小于等于0的数的，随便输'); exit; end; 
  if (Times <= 0) then 
  begin ShowMessage('重试次数不能少于0'); edtTimes.SetFocus; exit; end; 
 
  isMore := false; 
  for i := 0 to lvinfo.Items.Count - 1 do 
  begin 
    if lvinfo.Items[i].Caption = strName then 
    begin isMore := true; break; end; 
  end; 
  if isMore then 
  begin ShowMessage('模拟进程的名称要唯一哦'); edtName.SetFocus; exit; end; 
 
  edtName.SetFocus; 
 
  with lvinfo do //如果成功，写入进程信息列表中 
  begin 
    p := Items.Add; 
    p.Caption := strname; 
    p.SubItems.Add(intTostr(waitTime)); 
    p.SubItems.Add(intTostr(Retry)); 
    p.SubItems.Add(sRun); 
  end; 
  i := lvInfo.Items.Count - 1; 
  //创建模拟进程 
  DemoProcedure := TDemoProcedure.Create(); 
  DemoProcedure.strName := strName; 
  DemoProcedure.Times := Times; 
  DemoProcedure.ListIndex := i; 
  DemoProcedure.WaitTime := waitTime * 1000; 
  DemoProcedure.RetryTime := Retry * 1000; 
  DemoProcedure.Resume; 
end; 
 
procedure TMain.AddInfotoLvinfo(index: integer; s: string); 
begin 
  if lvinfo.Items.Count - 1 < index then exit; 
  if index < 0 then exit; 
  lvinfo.Items[index].SubItems[2] := s; ; 
end; 
 
function TMain.GetInfoFromlvInfo(index: integer): string; 
begin 
  result := lvinfo.Items[index].SubItems[2]; 
end; 
 
procedure TMain.AddInfo(s: string); 
begin 
  if not isMonitor then exit; 
  lbox.Items.Add(s); 
//  Application.ProcessMessages; 
end; 
 
{ TDemoProcedure } 
 
constructor TDemoProcedure.Create; 
begin 
  FreeOnTerminate := True; 
  inherited Create(True); 
end; 
 
procedure TDemoProcedure.donWantSource; 
begin 
  with Main do 
  begin 
    isDonotWantSource := not CheckBox1.checked; 
 
    if isDonotWantSource then 
    begin 
    //释放资源 
      edtuse.Text := '否'; 
      Edit1.Text := '无'; 
      edtSource.Text := intTostr(strToint(edtSource.Text) + 1); 
 
      AddinfoTolvinfo(ListIndex, '释放资源成功'); 
      Addinfo(format('%s 试图释放资源---资源尚未锁定，释放成功', [strname])); 
    end 
    else 
    begin 
      AddinfoTolvinfo(ListIndex, '释放资源失败'); 
      Addinfo(format('%s 试图释放资源---资源被用户锁定，释放失败，等待%d毫秒再试', [strname, retrytime])); 
    end; 
  end; 
end; 
 
procedure TDemoProcedure.donWantsourceOK; 
begin 
  with Main do 
  begin 
    AddinfoTolvinfo(ListIndex, '释放资源'); 
    Addinfo(format('%s 成功释放资源---释放资源后马上会自动终止本进程', [strname])); 
  end; 
end; 
 
procedure TDemoProcedure.EndThisRun; 
begin 
  with Main do 
  begin 
    addinfoTolvinfo(listindex, '成功结束'); 
    addinfo(format('%s 成功结束', [strName])); 
  end; 
end; 
 
procedure TDemoProcedure.Execute; 
var 
  i: integer; 
begin 
  i := 0; 
  repeat 
    synchronize(WantSource); 
    if isWantSource then break 
    else 
      sleep(RetryTime); 
    Inc(i); 
  until (i >= Times); 
  if i >= Times then 
  begin //未申请到资源退出 
    synchronize(self.ShowError); 
    self.Terminate; 
  end; 
  //进行运行态 
  synchronize(wantsourceOK); 
 
  //运行 
  sleep(waittime); //模拟 
 
  //运行完毕申请释放资源 
  i := 0; 
  repeat 
    synchronize(donWantSource); 
    if isDonotWantSource then break 
    else 
      sleep(RetryTime); 
    Inc(i); 
  until (i >= Times); 
  if i >= Times then 
  begin //未申请到资源退出 
    synchronize(self.ShowErrorEx); 
    self.Terminate; 
  end; 
  synchronize(donWantSourceOk); 
  synchronize(EndThisRun); 
//  self.Terminate; 
end; 
 
procedure TDemoProcedure.ShowError; 
begin 
  with Main do 
  begin 
    addinfoTolvinfo(ListIndex, '超时错误并停止'); 
    addinfo(format('%s 经过%d秒重试，仍然没有成功，超时并终止线程', [strName, RetryTime])); 
  end; 
end; 
 
procedure TDemoProcedure.ShowErrorEx; 
begin 
  with Main do 
  begin 
    addinfoTolvinfo(ListIndex, '超时错误并停止'); 
    addinfo(format('%s 经过%d秒重试，用户仍然锁定不准释放资源，为了防止死锁，强制释放并终止线程', [strName, RetryTime])); 
    edtuse.Text := '否'; 
    Edit1.Text := '无'; 
    edtSource.Text := intTostr(strToint(edtSource.Text) + 1); 
  end; 
end; 
 
procedure TDemoProcedure.WantSource; 
begin 
  with Main do 
  begin 
    if edtuse.Text = '是' then 
      self.isWantSource := false 
    else 
      self.isWantSource := True; 
    if isWantSource then 
    begin 
    //申请资源 
      edtuse.Text := '是'; 
      Edit1.Text := strname; 
      edtSource.Text := intTostr(strToint(edtSource.Text) - 1); 
 
      AddinfoTolvinfo(ListIndex, '申请资源成功'); 
      Addinfo(format('%s 试图申请资源---资源尚未使用，申请成功', [strname])); 
    end 
    else 
    begin 
      AddinfoTolvinfo(ListIndex, '申请资源失败'); 
      Addinfo(format('%s 试图申请资源---资源已在使用中，申请失败，等待%d毫秒再试', [strname, retrytime])); 
    end; 
  end; 
end; 
 
 
procedure TDemoProcedure.Wantsourceok; 
begin 
  with Main do 
  begin 
    AddinfoTolvinfo(ListIndex, '使用资源状态'); 
    Addinfo(format('%s 成功申请资源---正在使用过程中，将运行%d毫秒', [strname, waittime])); 
  end; 
end; 
 
end.

实现UP、DOWN原语产生3个进程

相关阅读:
数组例题解析
 第六章数组
 循环控制例题解析
 第五章循环控制
 第四章选择结构程序设计
 第三章数据的输入与输出
 第一章程序设计及C语言概述
 C 字符串类型例题讲解与实现字符串库函数
 0XX_javascript核心
 012品优购03
原文地址：https://www.cnblogs.com/marklove/p/12340681.html

ThreadedTimer 如题 线程定时器

ThreadedTimer 如题线程定时器