|
1、Unit2:
[delphi]
unit Unit2;
interface
uses
windows,classes,NMICMP,SysUtils,StdCtrls,messages;
const WM_MY_PING = WM_USER
+1024;
type
//要传递的消息记录.
TPingMsg =
record
msg : array[0..1023] of char;
id : integer;
Handled : boolean;
msg2 : string;
//建议如果需要动态管理，比如采用List,采用字符数组的方式会比较好，
//因为在动态使用结构时，如过没有处理好，采用string就可能会造成内存泄露.
//当然在这里例子中没关系.
end;
pPingMsg =
^TPingMsg;//定义结构体指针.
OnPinging =
procedure(Context: integer;Msg : string) of
object;
ThreadEnd =
procedure(Context: integer;Msg:string) of
object;
TMyPingThread = class(TThread)
private
FPingEvent : OnPinging;
FEndEvent : ThreadEnd;
FMsg : string;
FSequenceID : integer;
FWinHandl : Hwnd;
procedure OnPing(Sender: TObject; Host: String; Size, Time:
Integer);
procedure HandlingEnd;
procedure
HandlingPing;
protected
procedure Execute;override;
procedure DoTerminate;override;
public
//采用函数指针的方式，因为传递过来如果是UI控件类的方法，该方法需要访问UI元素，则需要做同步处理,
//否则可能会导致错误.
constructor Create(WinHandl : Hwnd; SequenceID : integer;OutPut:
OnPinging;EndEvent:
ThreadEnd);overload;
end;
implementation
{ TMyPingThread }
constructor TMyPingThread.Create(WinHandl : Hwnd;SequenceID :
integer;OutPut: OnPinging; EndEvent:
ThreadEnd);
begin
self.FPingEvent := OutPut;
self.FEndEvent := EndEvent;
FSequenceID
:= SequenceID;
FWinHandl :=
WinHandl;
inherited
Create(true);
end;
procedure
TMyPingThread.DoTerminate;
begin
inherited;
Synchronize(HandlingEnd);
end;
procedure
TMyPingThread.HandlingEnd();
begin
if Assigned(self.FEndEvent)
then
self.FEndEvent(FSequenceID,FMsg);
end;
procedure
TMyPingThread.HandlingPing();
begin
if assigned(self.FPingEvent)
then
FPingEvent(FSequenceID,FMsg);
end;
procedure TMyPingThread.Execute;
var
PingObj :
TNMPing;
begin
self.FreeOnTerminate :=
true;
PingObj :=
TNMPing.Create(nil);
PingObj.OnPing
:= OnPing;
try
PingObj.Pings := 30;
PingObj.Host := 'www.sohu.com';
PingObj.Ping;
finally
PingObj.Free;
end;
end;
procedure TMyPingThread.OnPing(Sender: TObject; Host: String;
Size,
Time:
Integer);
var
pMsg :
pPingMsg;
Msg :
TPingMsg;
begin
//不能直接定义结构体，因为是局部变量，如果是PostMessage,不会等待，会释放的.
//但如果采用如下的new方式，程序不会主动释放内存，需要配合Dispose方法用.
new(pmsg);
//这种情况下，消息接收方不一定能获取到正确的值.
FMsg := host+':'+
inttostr(size)+':'+inttostr(Time);
strcopy(@(pmsg.msg),pchar(FMsg));
pmsg.id :=
self.FSequenceID;
pmsg.Handled :=
false;
pmsg.msg2 :=
FMsg+'xxx';//注意，这里增加字符，并不能增加sizeof(pmsg^)
Msg.msg2 :=
FMsg+'xxxx';//注意，这里增加字符，并不能增加sizeof(Msg)
strcopy(@(Msg.msg),pchar(FMsg));
//postmessage(FWinHandl,WM_MY_PING,
self.FSequenceID,LPARAM(@Msg));
//因此我觉得采用SendMessage比较好，这样内存的释放可以在这里进行，不会造成内存泄露.
Sendmessage(FWinHandl,WM_MY_PING,
self.FSequenceID,LPARAM(@Msg));
//这种方法是让线程等待消息处理，实际上等效于SendMessage方法调用.
{while (pmsg.Handled=false)
do
begin
sleep(10);
end;
}
//采用等待方法则在这里释放空间。如果采用消息接收方处理，则这里不需要释放。
Dispose(Pmsg);
//Synchronize(HandlingPing);
end;
end.
2 form 调用Unit1
[delphi]
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms,
Dialogs,Unit2,
StdCtrls;
type
TForm1 =
class(TForm)
Memo1:
TMemo;
Button1:
TButton;
Memo2:
TMemo;
Memo3:
TMemo;
Memo4:
TMemo;
procedure
Button1Click(Sender: TObject);
private
{ Private
declarations }
FThreadCount : integer;
procedure
HandlingPing(Context:integer;Msg :
string);
procedure HanglingEnd(Context:integer;Msg :
string);
procedure OutPut(Context:integer;Msg :
string);
procedure PingMsgHdl(var Msg:TMessage);message
WM_MY_PING;
public
{ Public
declarations }
end;
var
Form1:
TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender:
TObject);
var
AThread :
TMyPingThread;
begin
FThreadCount :=
4;
AThread :=
TMyPingThread.Create(self.Handle,
1,HandlingPing,HanglingEnd);
AThread.Resume;
AThread :=
TMyPingThread.Create(self.Handle,2,HandlingPing,HanglingEnd);
AThread.Resume;
AThread :=
TMyPingThread.Create(self.Handle,3,HandlingPing,HanglingEnd);
AThread.Resume;
AThread :=
TMyPingThread.Create(self.Handle,4,HandlingPing,HanglingEnd);
AThread.Resume;
end;
procedure TForm1.HandlingPing(Context:integer;Msg:
string);
begin
OutPut(Context,Msg);
end;
procedure TForm1.HanglingEnd(Context:integer;Msg:
string);
begin
OutPut(Context,Msg);
FThreadCount := FThreadCount
-1;
OutPut(1,inttostr(FThreadCount));
end;
procedure TForm1.OutPut(Context: integer; Msg:
string);
begin
case context
of
1:
memo1.Lines.Append(Msg);
2:
memo2.Lines.Append(Msg);
3:
memo3.Lines.Append(Msg);
4:
memo4.Lines.Append(Msg);
end;
end;
procedure TForm1.PingMsgHdl(var
Msg:TMessage);
var
pMsg :
pPingMsg;
begin
pMsg :=
pPingMsg(Msg.LParam);
OutPut(Msg.WParam,
pmsg.msg2+'=>'+inttostr(sizeof(pmsg^)));
-
六六分期app的软件客服如何联系？不知道吗？加qq群【895510560】即可！标题：六六分期
阅读：19187|2023-10-27
-
今天小编告诉大家如何处理win10系统火狐flash插件总是崩溃的问题，可能很多用户都不知
阅读：9988|2022-11-06
-
今天小编告诉大家如何对win10系统删除桌面回收站图标进行设置，可能很多用户都不知道
阅读：8325|2022-11-06
-
今天小编告诉大家如何对win10系统电脑设置节能降温的设置方法，想必大家都遇到过需要
阅读：8695|2022-11-06
-
我们在使用xp系统的过程中,经常需要对xp系统无线网络安装向导设置进行设置，可能很多
阅读：8639|2022-11-06
-
今天小编告诉大家如何处理win7系统玩cf老是与主机连接不稳定的问题，可能很多用户都不
阅读：9656|2022-11-06
-
电脑对日常生活的重要性小编就不多说了，可是一旦碰到win7系统设置cf烟雾头的问题，很
阅读：8623|2022-11-06
-
我们在日常使用电脑的时候，有的小伙伴们可能在打开应用的时候会遇见提示应用程序无法
阅读：7998|2022-11-06
-
今天小编告诉大家如何对win7系统打开vcf文件进行设置，可能很多用户都不知道怎么对win
阅读：8654|2022-11-06
-
今天小编告诉大家如何对win10系统s4开启USB调试模式进行设置，可能很多用户都不知道怎
阅读：7535|2022-11-06
|
客服电话
APP下载
官方微信
请发表评论