unit1.pas

《Delphi百例》源码?禗elphi百例》源码

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Winsock;

type
    PIPOptionInformation = ^TIPOptionInformation;
    TIPOptionInformation = packed record
    TTL: Byte;
    TOS: Byte;
    Flags: Byte;
    OptionsSize: Byte;
    OptionsData: PChar;
    end;
    PIcmpEchoReply = ^TIcmpEchoReply;
    TIcmpEchoReply = packed record
    Address: DWORD;
    Status: DWORD;
    RTT: DWORD;
    DataSize: Word;
    Reserved: Word;
    Data: Pointer;
    Options: TIPOptionInformation;
    end;
    TIcmpCreateFile = function: THandle; stdcall;
    TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;
    TIcmpSendEcho = function(IcmpHandle:THandle;DestinationAddress: DWORD;
    RequestData: Pointer;
    RequestSize: Word;
    RequestOptions: PIPOptionInformation;
    ReplyBuffer: Pointer;
    ReplySize: DWord;
    Timeout: DWord
    ): DWord; stdcall;

  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    PingEdit: TEdit;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    hICMP: THANDLE;
    IcmpCreateFile : TIcmpCreateFile;
    IcmpCloseHandle: TIcmpCloseHandle;
    IcmpSendEcho: TIcmpSendEcho;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
Var
    WSAData: TWSAData;
    hICMPdll: HMODULE;
begin
    // Load the icmp.dll stuff
    hICMPdll := LoadLibrary('icmp.dll');
    @ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');
    @IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');
    @IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');
    hICMP := IcmpCreateFile;
    Memo1.Text := '';
    Memo1.Lines.Add('IP地址         字节 返回(毫秒)');
end;

procedure TForm1.Button1Click(Sender: TObject);
var
    IPOpt:TIPOptionInformation;// IP Options for packet to send
    FIPAddress:DWORD;
    pReqData,pRevData:PChar;
    pIPE:PIcmpEchoReply;// ICMP Echo reply buffer
    FSize: DWORD;
    MyString:string;
    FTimeOut:DWORD;
    BufferSize:DWORD;
Begin
    if PingEdit.Text <> '' then
    begin
    FIPAddress := inet_addr(PChar(PingEdit.Text));
    FSize := 40;
    BufferSize := SizeOf(TICMPEchoReply) + FSize;
    GetMem(pRevData,FSize);
    GetMem(pIPE,BufferSize);
    FillChar(pIPE^, SizeOf(pIPE^), 0);
    pIPE^.Data := pRevData;
    MyString := 'Hello,World';
    pReqData := PChar(MyString);
    FillChar(IPOpt, Sizeof(IPOpt), 0);
    IPOpt.TTL := 64;
    FTimeOut := 2000;
    IcmpSendEcho(hICMP, FIPAddress, pReqData, Length(MyString),@IPOpt, pIPE, BufferSize, FTimeOut);
    try
      try
        if pReqData^ = pIPE^.Options.OptionsData^ then
          Memo1.Lines.Add(PChar(PingEdit.Text) + ' ' +IntToStr(pIPE^.DataSize) + ' ' +IntToStr(pIPE^.RTT));
      except
        Exit;
      end;
    finally
      FreeMem(pRevData);
      FreeMem(pIPE);
    end;
    end
end;

end.