[Admin]

Код:

(*
  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