![Старый](images/statusicon/post_old.gif)
02.08.2015, 14:57
|
![Аватар для Admin](image.php?s=96652ab792ab1ed8d7dfa822665c8e2b&u=1&dateline=1128338681) |
Администратор
|
|
Регистрация: 03.10.2005
Адрес: Россия, Москва
Сообщения: 1,531
Версия Delphi: Delphi 7
Репутация: выкл
|
|
[ Исходник ] - Пинг сети
Код:
(*
Simple web server exemple
tdjprog 1998 - 2015
tdjprog@yahoo.fr
*)
unit Main;
interface
uses
Windows, Messages, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls,
SysUtils, Classes, IdIcmpClient, IdBaseComponent, IdComponent, IdRawBase, IdRawClient;
type
TfrmPing = class(TForm)
Panel1: TPanel;
btPing: TButton;
mReplies: TMemo;
btStop: TButton;
edHosts: TEdit;
procedure btPingClick(Sender: TObject);
procedure btStopClick(Sender: TObject);
private
procedure OnThreadPingTerminate(Sender: TObject);
public
end;
TPing = class (TThread)
private
FPing: TIdIcmpClient;
FPingResult: String;
function GetPHost: String;
procedure PingReplay(ASender: TComponent; const ReplyStatus: TReplyStatus);
protected
procedure DoPingHost;
procedure Execute; override;
public
constructor Create(const PAddr: String; OnTerminateEvent: TNotifyEvent);
destructor Destroy; override;
property PResults: String read FPingResult;
property PHost: String read GetPHost;
end;
var
frmPing: TfrmPing;
StopThreads: Boolean = False;
implementation
{$R *.DFM}
function TPing.GetPHost: String;
begin
Result:= '';
if Assigned(FPing) then
Result:= FPing.Host;
end;
procedure TPing.PingReplay(ASender: TComponent; const ReplyStatus: TReplyStatus);
var
sTime: string;
begin
// TODO: check for error on ping reply (ReplyStatus.MsgType?)
if (ReplyStatus.MsRoundTripTime = 0) then
sTime := '<1'
else
sTime := '=';
FPingResult:= Format('%s%d bytes from %s: icmp_seq=%d ttl=%d time%s%d ms',
[FPingResult,
ReplyStatus.BytesReceived,
ReplyStatus.FromIpAddress,
ReplyStatus.SequenceId,
ReplyStatus.TimeToLive,
sTime,
ReplyStatus.MsRoundTripTime]) + #13#10;
end;
constructor TPing.Create(const PAddr: String; OnTerminateEvent: TNotifyEvent);
begin
inherited Create(True);
FreeOnTerminate := True;
OnTerminate := OnTerminateEvent;
FPing := TIdIcmpClient.Create(nil);
FPing.ReceiveTimeout := 1000;
FPing.Host := PAddr;
FPing.OnReply := PingReplay;
//FAddr := PAddr;
FPingResult := '';
end;
destructor TPing.Destroy;
begin
if Assigned(FPing) then
FPing.Free;
inherited Destroy;
end;
procedure TPing.DoPingHost;
begin
FPing.Ping;
Application.ProcessMessages;
end;
procedure TPing.Execute;
var i: Byte;
begin
i:= 1;
while (i <= 4) and (not Terminated) and (not StopThreads) do
begin
Synchronize(DoPingHost);
Inc(i);
end;
end;
procedure TfrmPing.OnThreadPingTerminate(Sender: TObject);
begin
with (Sender as TPing) do
begin
mReplies.Lines.Add(Format('Host [%s]', [PHost]));
mReplies.Lines.Add(Format('%s', [PResults]));
end;
end;
procedure TfrmPing.btPingClick(Sender: TObject);
var i: Integer;
begin
StopThreads:= False;
for i:= 210 to 230 do
begin
if StopThreads then
Break;
with TPing.Create(Format(edHosts.Text, [i]), OnThreadPingTerminate) do
Resume;
Application.ProcessMessages;
end;
end;
procedure TfrmPing.btStopClick(Sender: TObject);
begin
StopThreads:= True;
end;
end.
Автор: cs_AccessToYou
Ссылка: http://codes-sources.commentcamarche...101103/1374211
|