////////////////////////////////////////////////////
// //
// 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.
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.
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个进程