【Delphi】基于WinSock的Ping程序

 

unit uMainForm;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.StdCtrls, Vcl.ExtCtrls, uIcmp, uWinSock;

type
  TMainForm = class(TForm)
    Memo1: TMemo;
    ButtonPing: TButton;
    EditHost: TLabeledEdit;
    EditCount: TLabeledEdit;
    EditTimeOut: TLabeledEdit;
    EditDataLen: TLabeledEdit;
    procedure ButtonPingClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure EditHostKeyPress(Sender: TObject; var Key: Char);
  private
    Icmp: IIcmp;
    Timer: TTimer;
    Host, IP: String;
    WinSock: IWinSock;
    SendCount, RecvCount, MaxCount: Integer;
  private
    procedure TimerProc(Sender: TObject);
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

procedure TMainForm.EditHostKeyPress(Sender: TObject; var Key: Char);
begin
  if (Key = #13) and (ButtonPing.Caption = 'Ping') then
    ButtonPingClick(nil);
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  WinSock := TiWinSock.Create;

  Timer:= TTimer.Create(Self);
  Timer.Enabled := False;
  Timer.OnTimer := TimerProc;
  EditHost.Text := '114.114.114.114';
end;

procedure TMainForm.TimerProc(Sender: TObject);
begin
  with Icmp.Ping(IP) do
  begin
    if Status = 0 then
    begin
      Inc(RecvCount);
      Memo1.Lines.Add(Format('Reply from %s: bytes=%d time=%dms TTL=%d',
                            [IP, Size, RTT, TTL]));
    end
    else
      Memo1.Lines.Add(Msg);
  end;
  Inc(SendCount);
  if SendCount >= MaxCount then
    ButtonPingClick(nil);
end;

procedure TMainForm.ButtonPingClick(Sender: TObject);
var
  S: String;
  LostCount, TimeOut, DataLen: Integer;
begin
  if ButtonPing.Caption = 'Stop' then
  begin
    Timer.Enabled := False;
    ButtonPing.Caption := 'Ping';
    LostCount := SendCount - RecvCount;
    Memo1.Lines.Add(Format('Ping statistics for %s:', [Host]));
    Memo1.Lines.Add(Format('Packets: Sent = %d, Received = %d, Lost = %d (%d%% loss)',
        [SendCount, RecvCount, LostCount, Round(100*LostCount/SendCount)]));
  end
  else
  begin
    if Host <> EditHost.Text then
    begin
      IP := WinSock.GetIP(EditHost.Text);
      if WinSock.Status = False then
      begin
        Memo1.Lines.Add(IP);
        Exit
      end;
      Host := EditHost.Text;
    end;
    if Memo1.Lines.Count > 0 then Memo1.Lines.Add('');

    TimeOut := StrToInt(EditTimeOut.Text);
    DataLen := StrToInt(EditDataLen.Text);
    Icmp := TiIcmp.Create(TimeOut, DataLen);;
    ButtonPing.Caption := 'Stop';
    Application.ProcessMessages;

    if Host = IP  then
      S := ''
    else
      S := ' [' + IP +']';

    Memo1.Lines.Add(Format('Pinging %s%s with 32 bytes of data', [Host, S]));
    SendCount := 0;
    RecvCount := 0;
    MaxCount := StrToInt(EditCount.Text);
    TimerProc(nil);
    Timer.Enabled := True;
  end;
end;

end.

  --- uMainForm.dfm 

object MainForm: TMainForm
  Left = 0
  Top = 0
  Anchors = [akLeft, akTop, akRight, akBottom]
  Caption = 'WinPing'
  ClientHeight = 496
  ClientWidth = 565
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  DesignSize = (
    565
    496)
  PixelsPerInch = 96
  TextHeight = 13
  object ButtonPing: TButton
    Left = 492
    Top = 462
    Width = 65
    Height = 25
    Anchors = [akRight, akBottom]
    Caption = 'Ping'
    TabOrder = 1
    OnClick = ButtonPingClick
  end
  object Memo1: TMemo
    Left = 7
    Top = 8
    Width = 551
    Height = 446
    Anchors = [akLeft, akTop, akRight, akBottom]
    ReadOnly = True
    TabOrder = 5
  end
  object EditHost: TLabeledEdit
    Left = 326
    Top = 465
    Width = 154
    Height = 21
    Alignment = taCenter
    Anchors = [akRight, akBottom]
    EditLabel.Width = 24
    EditLabel.Height = 13
    EditLabel.Caption = #20027#26426
    LabelPosition = lpLeft
    TabOrder = 0
    Text = 'www.microsoft.com'
    OnKeyPress = EditHostKeyPress
  end
  object EditCount: TLabeledEdit
    Left = 55
    Top = 465
    Width = 40
    Height = 21
    Alignment = taCenter
    Anchors = [akLeft, akBottom]
    EditLabel.Width = 44
    EditLabel.Height = 13
    EditLabel.Caption = 'ping'#27425#25968
    LabelPosition = lpLeft
    TabOrder = 2
    Text = '4'
  end
  object EditTimeOut: TLabeledEdit
    Left = 134
    Top = 465
    Width = 46
    Height = 21
    Alignment = taCenter
    Anchors = [akLeft, akBottom]
    EditLabel.Width = 24
    EditLabel.Height = 13
    EditLabel.Caption = #36229#26102
    LabelPosition = lpLeft
    TabOrder = 3
    Text = '4000'
  end
  object EditDataLen: TLabeledEdit
    Left = 244
    Top = 465
    Width = 40
    Height = 21
    Alignment = taCenter
    Anchors = [akLeft, akBottom]
    EditLabel.Width = 48
    EditLabel.Height = 13
    EditLabel.Caption = #25968#25454#38271#24230
    LabelPosition = lpLeft
    TabOrder = 4
    Text = '32'
  end
end

unit uIcmp;

interface

uses
  Windows, SysUtils, Classes, WinSock2{或WinSock};

type
  TPingResult = record
    Status: DWORD;
    IP    : String;
    Size  : Integer;
    RTT   : Integer;
    TTL   : Integer;
    Msg   : String;
  end;

  IIcmp = interface
    function Ping(const aIP: String): TPingResult;
  end;

  TiIcmp = class
  public
    class function Create(aTimeOut: DWORD = 4000; aDataLen: DWORD = 32): IIcmp;
  end;

implementation

uses uWinSock, uIcmpDict;

//type  如果旧新版本Delphi没有这些定义，需开启这些定义
  //PVOID  = Pointer;
  //LPVOID = Pointer;
  //PByte  = ^Byte  ;

type
  LPOptionInfo = ^TOptionInfo;
  TOptionInfo = record
    TTL  : Byte;  //Time to Live
    TOS  : Byte;  //type of service, currently silently ignored
    Flags: Byte;  //Flags field
    OptionsSize: Byte;  //size of IP options data
    OptionsData: {$IFNDEF Win64} PByte {$ELSE} UInt32 {$ENDIF};//pointer to options data
  end;

  LPEchoReply = ^TEchoReply;
  TEchoReply = record
    Address: DWORD; //replying address
    Status : DWORD;  //status of the echo request
    RoundTripTime: DWORD; //round trip time in milliseconds
    DataSize: WORD; //data size of the reply
    Reserved: WORD;  //Reserved for system use
    Data: PVOID;   //pointer to the reply data
    Options: TOptionInfo; //IP options in the IP header of the reply
  end;

  TReplyBuffer = record
    EchoReply   : TEchoReply;
    Reserved: array[0..1024-1] of Byte;
  end;

type
  TCreateFile  = function: THandle; stdcall;
  TCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;
  TSendEcho    = function(IcmpHandle: THandle;
                          DestinationAddress: DWORD;
                          RequestData: LPVOID;
                          RequestSize: WORD;
                          RequestOptions: LPOptionInfo;
                          ReplyBuffer: LPVOID;
                          ReplySize: DWORD;
                          TimeOut: DWORD
                  ): DWORD; stdcall;

//-------------------------------------------------------------------------

type
  TIcmp = class(TInterfacedObject, IIcmp)
  private
    hIcmp: THANDLE;
    hIcmpDLL: HMODULE;
    CreateHandle: TCreateFile ;
    CloseHandle : TCloseHandle;
    SendEcho: TSendEcho;
  private
    IpDWord: DWORD;
    ReqData: AnsiString;
    ReplyBuffer: TReplyBuffer;
    ReplyData: array[0..1024-1] of Byte;
    TimeOut, DataLen: DWORD;
    procedure FillReqData;
  public
    function Ping(const aIP: String): TPingResult;
  public
    constructor Create(aTimeOut: DWORD = 4000; aDataLen: DWORD = 32);
    destructor Destroy; override;
  end;

constructor TIcmp.Create(aTimeOut, aDataLen: DWORD);
begin
  inherited Create;
  TimeOut := aTimeOut;
  DataLen := aDataLen;
  hIcmpDLL := SafeLoadLibrary('icmp.dll');
  @CreateHandle:= GetProcAddress(hIcmpDLL, 'IcmpCreateFile' );
  @CloseHandle := GetProcAddress(hIcmpDLL, 'IcmpCloseHandle');
  @SendEcho    := GetProcAddress(hIcmpDLL, 'IcmpSendEcho'   );
  hIcmp := CreateHandle;
  FillReqData;
end;

destructor TIcmp.Destroy;
begin
  FreeLibrary(hIcmpDLL);
  CloseHandle(hIcmp);
  inherited;
end;

function TIcmp.Ping(const aIP: String): TPingResult;
begin
  if aIP = '' then
  begin
    Result.Status := 1;
    Result.IP  := '';
    Result.Size:= 0;
    Result.RTT := 0;
    Result.TTL := 0;
    Result.Msg := 'Host name is empty.';
    Exit;
  end;

  IpDWord := INet_Addr(PAnsiChar(AnsiString(aIP)));

  ZeroMemory(@ReplyBuffer, Sizeof(ReplyBuffer));
  ZeroMemory(@ReplyData  , Sizeof(ReplyData  ));
  ReplyBuffer.EchoReply.Data := @ReplyData;

  SendEcho(hIcmp, IpDWord, PAnsiChar(ReqData), Length(ReqData),
           nil, @ReplyBuffer, SizeOf(ReplyBuffer), TimeOut   );
  with ReplyBuffer.EchoReply do
  begin
    Result.Status := Status;
    Result.IP     := String(INet_NtoA(In_Addr(Address)));
    Result.Size   := DataSize;
    Result.RTT    := RoundTripTime;
    Result.TTL    := Options.TTL;
    Result.Msg    := IcmpDict.Items[Status];
  end;
end;

procedure TIcmp.FillReqData;
var
  P: PByte;
  I, J: Integer;
begin //ReqData = '12345678901234567890123456789012...'
  SetLength(ReqData, DataLen);
  P := @ReqData[1];
  for I := 0 to DataLen - 1 do
  begin
    J := (I+1) mod 10;
    (P + I)^ := (48 + J);
  end;
end;

//=============================================================================

class function TiIcmp.Create(aTimeOut, aDataLen: DWORD): IIcmp;
begin
  Result := TIcmp.Create(aTimeOut, aDataLen);
end;

end.

unit uWinSock;

interface

uses
  Windows, SysUtils, Classes, WinSock2;

type
  IWinSock = interface
    function GetIP(const aHost: String): String;
    function Status: Boolean;
  end;

  TiWinSock = class
  public
    class function Create: IWinSock;
  end;

implementation

uses uWinSockDict;

type
  LPAddrInfoW  = ^TADDRINFOW ;
  LPPaddrinfoW = ^LPAddrInfoW;
  TADDRINFOW = record
    Flags    : Integer; //indicate options used in the getaddrinfo function
    Family   : Integer; //address family：AF_INET、AF_INET6...
    SockType : Integer; //socket type: SOCK_STREAM、SOCK_DGRAM...
    Protocol : Integer; //protocol type: IPPROTO_TCP、IPPROTO_UDP、IPPROTO_RM
    AddrLen  : SIZE_T;  //Length of Addr member
    CanonName: PWideChar;  //canonical name for the host
    Addr     : PInAddr;    //pointer to a sockaddr structure
    Next     : LPAddrInfoW;//pointer to the next structure in a linked list
  end;

  TGetAddrInfo = function(NodeName   : PWideChar  ;
                          ServiceName: PWideChar  ;
                          Hints      : LPAddrInfoW;
                          ppResult   : LPPaddrinfoW
                 ): Integer; stdcall;
  TFreeAddrInfo = procedure(AddrInfo: LPAddrInfoW); stdcall;

//-------------------------------------------------------------------------

type
  TWinSock = class(TInterfacedObject, IWinSock)
  private
    FStatus: Boolean;
    hWinSock: THandle;
    GetAddrInfo : TGetAddrInfo;
    FreeAddrInfo: TFreeAddrInfo;
  private
    function IsIP(AIP: string): Boolean;
    function HostByName(const aHost: string): string;
    function Fetch(var aIP: string): Integer; inline;
  public
    function GetIP(const aHost: string): String;
    function Status: Boolean;
  public
    constructor Create;
    destructor Destroy; override;
  end;

constructor TWinSock.Create;
begin
  hWinSock := SafeLoadLibrary('ws2_32.dll');
  @GetAddrInfo  := GetProcAddress(hWinSock, 'GetAddrInfoW');
  @FreeAddrInfo := GetProcAddress(hWinSock, 'FreeAddrInfoW');
end;

destructor TWinSock.Destroy;
begin
  FreeLibrary(hWinSock);
end;

function TWinSock.GetIP(const aHost: string): String;
begin
  FStatus := True;
  if AnsiCompareText(aHost, 'LOCALHOST') = 0
  then
  begin
    Result := '127.0.0.1';
  end
  else if IsIP(aHost) then
  begin
    Result := aHost;
  end
  else
  begin
    Result := HostByName(aHost);
  end;
end;

function TWinSock.HostByName(const aHost: string): string;
var
  RetVal: Cardinal;
  Hints: TADDRINFOW;
  wsaData: TWSADATA;
  pAddrInfo: LPAddrInfoW;
begin
  WSAStartup(MAKEWORD(2, 2), &wsaData);
  ZeroMemory(@Hints, SizeOf(Hints));
  Hints.Family   := AF_INET;
  Hints.SockType := SOCK_STREAM;
//Hints.Protocol := IPPROTO_TCP;
  pAddrInfo := nil;

  RetVal := GetAddrInfo(PChar(aHost), nil, @Hints, @pAddrInfo);
  WSACleanup();

  if RetVal = 0 then
  begin
    Result := String(INet_NtoA(PSockAddrIn(pAddrInfo^.Addr)^.sin_addr));
    FreeAddrInfo(pAddrInfo);
  end
  else
  begin
    FStatus := False;
    if WinSockDict.ContainsKey(RetVal) then
    begin
      Result := WinSockDict.Items[RetVal]
    end
    else
      Result := 'Unknown Error';
  end;
end;

function TWinSock.IsIP(aIP: string): Boolean;
var
  I: Integer;
begin
  Result := True;
  for I := 1 to 4 do
  begin
    if not Fetch(aIP) in [0..255] then
    begin
      Result := False;
      Exit;
    end
  end;
end;

function TWinSock.Fetch(var aIP: string): Integer;
var
  P: Integer;
  S: String;
begin
  P := Pos('.', aIP);
  if P = 0 then
  begin
    S := aIP;
    aIP := ''
  end
  else
  begin
    S   := aIP.SubString(0, P-2);
    aIP := aIP.SubString(P, aIP.Length);
  end;
  Result := StrToIntDef(Trim(S), -1);
end;

function TWinSock.Status: Boolean;
begin
  Result := FStatus;
end;

//=============================================================================

class function TiWinSock.Create:IWinSock;
begin
  Result := TWinSock.Create;
end;

end.

unit uIcmpDict;

interface

uses Generics.Collections, Winapi.IpExport;

type
  TIcmpDict = TDictionary<Cardinal, String>;

var
  IcmpDict: TIcmpDict;

implementation

initialization
  IcmpDict := TIcmpDict.Create;

  with IcmpDict do
  begin
    Add(IP_SUCCESS              , 'The status was success.');
    Add(IP_BUF_TOO_SMALL        , 'The reply buffer was too small.');
    Add(IP_DEST_NET_UNREACHABLE , 'The destination network was unreachable.');
    Add(IP_DEST_HOST_UNREACHABLE, 'The destination host was unreachable.');
    Add(IP_DEST_PROT_UNREACHABLE, 'The destination protocol was unreachable.');
    Add(IP_DEST_PORT_UNREACHABLE, 'The destination port was unreachable.');
    Add(IP_NO_RESOURCES         , 'Insufficient IP resources were available.');
    Add(IP_BAD_OPTION           , 'A bad IP option was specified.');
    Add(IP_HW_ERROR             , 'A hardware error occurred.');
    Add(IP_PACKET_TOO_BIG       , 'The packet was too big.');
    Add(IP_REQ_TIMED_OUT        , 'The request timed out.');
    Add(IP_BAD_REQ              , 'A bad request.');
    Add(IP_BAD_ROUTE            , 'A bad route.');
    Add(IP_TTL_EXPIRED_TRANSIT  , 'The time to live (TTL) expired in transit.');
    Add(IP_TTL_EXPIRED_REASSEM  , 'The time to live expired during fragment reassembly.');
    Add(IP_PARAM_PROBLEM        , 'A parameter problem.');
    Add(IP_SOURCE_QUENCH        , 'Datagrams are arriving too fast to be processed and datagrams may have been discarded.');
    Add(IP_OPTION_TOO_BIG       , 'An IP option was too big.');
    Add(IP_BAD_DESTINATION      , 'A bad destination.');
    Add(IP_GENERAL_FAILURE      , 'A general failure. This error can be returned for some malformed ICMP packets.');
  end;

finalization
  IcmpDict.Free;

end.

unit uWinSockDict;

interface

uses WinSock2, Generics.Collections;

type
  TWinSockDict = TDictionary<Cardinal, String>;

var
  WinSockDict: TWinSockDict;

implementation


initialization
  WinSockDict := TWinSockDict.Create;

  with WinSockDict do
  begin
    Add(WSA_NOT_ENOUGH_MEMORY, 'There was insufficient memory to perform the operation.');
    Add(WSAEAFNOSUPPORT      , 'An address incompatible with the requested protocol was used.');
    Add(WSAEINVAL            , 'An invalid argument was supplied.');
    Add(WSAESOCKTNOSUPPORT   , 'The support for the specified socket type does not exist in this address family.');
    Add(WSAHOST_NOT_FOUND    , 'No such host is known.');
    Add(WSANO_DATA           , 'The requested name is valid, but no data of the requested type was found.');
    Add(WSANO_RECOVERY       , 'A nonrecoverable error occurred during a database lookup.');
    Add(WSANOTINITIALISED    , 'A successful WSAStartup call must occur before using this function.');
    Add(WSATRY_AGAIN         , '	This is usually a temporary error during hostname resolution and means that the local server did not receive a response from an authoritative server.');
    Add(WSATYPE_NOT_FOUND    , 'The specified class was not found.');
  end;

finalization
  WinSockDict.Free;

end.