unit1.pas

来自「delhpi经典游戏程序设计40例,大家不防下载看看.源码全在项目文件里!」· PAS 代码 · 共 153 行

unit Unit1;

interface

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

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;
  TMyPing = class(TForm)
    Label1: TLabel;
    PingEdit: TEdit;
    ExeBtn: TButton;
    StatusShow: TMemo;
    Label2: TLabel;
    Label3: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure ExeBtnClick(Sender: TObject);
    procedure Label2MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Private declarations }
    hICMP: THANDLE;
    IcmpCreateFile : TIcmpCreateFile;
    IcmpCloseHandle: TIcmpCloseHandle;
    IcmpSendEcho: TIcmpSendEcho;
  public
    { Public declarations }
    
  end;

var
  MyPing: TMyPing;

implementation

{$R *.dfm}

procedure TMyPing.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;
  StatusShow.Text := '';
  StatusShow.Lines.Add('目的IP地址 字节数 返回时间(毫秒)');
end;
procedure TMyPing.ExeBtnClick(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 := 4000;

  IcmpSendEcho(hICMP, FIPAddress, pReqData, 
Length(MyString),
@IPOpt, pIPE, BufferSize, FTimeOut);

  if pReqData^ = pIPE^.Options.OptionsData^ then

  begin

  StatusShow.Lines.Add(PChar(PingEdit.Text) + ' '
+IntToStr(pIPE^.DataSize) + ' ' +IntToStr(pIPE^.RTT));

  end;

  begin

  StatusShow.Lines.Add(PChar(PingEdit.Text) + ' '+IntToStr(pIPE^.DataSize) + ' ' +IntToStr(pIPE^.RTT));

  end;

  FreeMem(pRevData);

  FreeMem(pIPE);

  end
end;
  procedure TMyPing.Label2MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Label2.Color:=clRed;
  ShellExecute(handle,nil,pchar('http://www.thysea.com'),nil,nil,SW_SHOWNORMAL);
end;

end.