upingthread.~pas

来自「这个是Delphi 2007下写的」· ~PAS 代码 · 共 105 行

unit uPingThread;
{
  用于Ping主机的线程，需要Indy10
  Ver1.0         By 木桩 2008.01
}
interface

uses
  Windows, SysUtils, Classes, Messages,
  IdBaseComponent, IdComponent, IdRawBase, IdRawClient, IdIcmpClient;

const
  WM_STRINFO = WM_USER + 101;
  _PingSendCount  = 4;

type
  TPingThread = class(TThread)
    fPingFinish: Boolean;
    fState: String;
    fSumRoundTrip: Cardinal;
    fdwNotifyWnd: Cardinal;
  private
    { Private declarations }
    IdIcmpClientA: TIdIcmpClient;
    procedure OnICMPReply(ASender: TComponent; const AReplyStatus: TReplyStatus);
  protected
    procedure Execute; override;
  public
    constructor Create(RecvhWnd: Cardinal; PingHost: String; PingTimeout: Integer = 2000);
    destructor Destroy(); override;

    property isPingFinish: Boolean read fPingFinish;
  end;

implementation

{ TPingThread }

constructor TPingThread.Create(RecvhWnd: Cardinal; PingHost: String; PingTimeout: Integer = 2000);
begin
  FreeOnTerminate := True;

  fdwNotifyWnd := RecvhWnd;        // 接收消息
  IdIcmpClientA := TIdIcmpClient.Create(nil);
  IdIcmpClientA.OnReply := OnICMPReply;
  IdIcmpClientA.ReceiveTimeout := PingTimeout;
  IdIcmpClientA.Host := PingHost;

  fState := '';
  fSumRoundTrip := 0;
  
  inherited Create(False);
end;

destructor TPingThread.Destroy();
begin
  IdIcmpClientA.Free;
  
  inherited Destroy;
end;

procedure TPingThread.Execute;
var
  i: Integer;
begin
  fPingFinish := False;

  for i := 1 to _PingSendCount do
  begin
    IdIcmpClientA.Ping();
    if (fState = '超时') then Break;
  end;

  if Not(fState = '超时') then
  begin
    if (fSumRoundTrip = 0) then
      fState := '无效'
    else
      fState := Format('%0.1fms', [fSumRoundTrip/_PingSendCount]);
  end;
  SendMessage(fdwNotifyWnd, WM_STRINFO, Integer(fState), Integer(IdIcmpClientA.Host));
  fPingFinish := True;
end;

procedure TPingThread.OnICMPReply(ASender: TComponent; const AReplyStatus: TReplyStatus);
begin
  case AReplyStatus.ReplyStatusType of
    rsEcho:                               //收到目标主机的应答
      begin
        // 不知为什么不加会收到其他节点的回应
        if AReplyStatus.FromIpAddress = IdIcmpClientA.Host then
          fSumRoundTrip := fSumRoundTrip + AReplyStatus.MsRoundTripTime;
      end;
    rsTimeOut:                            //发送数据包超时
      begin
        fState := '超时';
      end;
    rsError: fState := 'rsError'; //'数据包格式错误，发送失败！';
    rsErrorUnreachable: fState := 'rsUnreachable'; //'该数据包无法送达目标主机！';
    rsErrorTTLExceeded: fState := 'rsTTLExceeded';//'TOL超时，数据包被丢弃。';
  end;
end;

end.