unit1.pas

来自「精彩编程百例75～100 其中有媒体播放器 SQL语言编辑器 ADO方法连接多个」· PAS 代码 · 共 134 行

unit Unit1;

interface

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

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;
  TTMyPing = class(TForm)
    PingEdit: TEdit;
    Label1: TLabel;
    StatusShow: TMemo;
    exebtn: TButton;
    Button1: TButton;
    Bevel1: TBevel;
    Bevel2: TBevel;
    procedure exebtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    hICMP: THANDLE;
     IcmpCreateFile : TIcmpCreateFile;
     IcmpCloseHandle:TIcmpCloseHandle;
     IcmpSendEcho: TIcmpSendEcho;
  public
   WSAData:TWSAData;
       { Public declarations }
  end;

var
  TMyPing: TTMyPing;

implementation

{$R *.DFM}

procedure TTMyPing.exebtnClick(Sender: TObject);
var
  IPOpt:TIPOptionInformation;
   FIPAddress:DWORD;
   pReqData,pRevData:PChar;
   pIPE:PIcmpEchoReply;
   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
     begin
       StatusShow.Lines.Add(PChar(PingEdit.Text) + '－－－'
           +IntToStr(pIPE^.DataSize) + '－－－－－' +IntToStr(pIPE^.RTT));
     end;
    except
     showmessage('无法连接');
   end;
  finally
      FreeMem(pRevData);
      FreeMem(pIPE);
  end;
 end
else
  showmessage('您还未输入IP地址');
end;

procedure TTMyPing.Button1Click(Sender: TObject);
begin
close;
end;

procedure TTMyPing.FormCreate(Sender: TObject);
var
 hICMPdll: HMODULE;
begin
  WSAStartup(2,WSAData);
  hICMPdll := LoadLibrary('icmp.dll');
  @ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');
  @IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');
  @IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');
  hICMP :=IcmpCreateFile;
   StatusShow.Text := '';
    StatusShow.Lines.Add('－－IP－－－－－bytes－－－－－ms');
end;

procedure TTMyPing.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 WSACleanup();
end;



end.