www.pudn.com > 推箱子源码.rar > MainUnit.pas

unit MainUnit; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  StdCtrls,winsock, ExtCtrls; 
 
type 
  DWORD = LongWord; 
  THandle = LongWord; 
  PIPOptionInformation = ^TIPOptionInformation; 
  TIPOptionInformation = 
    record 
      TTL: Byte; 
      TOS: Byte; 
      Flags: Byte; 
      OptionsSize: Byte; 
      OptionsData: PChar; 
    end; 
 
  PIcmpEchoReply = ^TIcmpEchoReply; 
  TIcmpEchoReply = 
    record 
      Address: DWORD; 
      Status: DWORD; 
      RTT: DWORD; 
      DataSize:Word; 
      Reserved: Word; 
      Data: Pointer; 
      Options: TIPOptionInformation; 
    end; 
    //========ICMP.dll中定义的函数============================ 
    function IcmpCreateFile():THandle;stdcall external 'ICMP.dll'; 
    function IcmpCloseHandle(Handle:THandle):Boolean;stdcall external 'ICMP.dll'; 
    function IcmpSendEcho(Handle:THandle; 
                          DestAddr:DWORD; 
                          RequestData: Pointer; 
                          RequestSize: Word; 
                          RequestOptions: PIPOptionInformation; 
                          ReplyBuffer: Pointer; 
                          ReplySize: DWORD; 
                          Timeout: DWORD  ): DWORD;stdcall external 'ICMP.dll'; 
    //======================================================== 
    procedure ValidCheck(); 
    procedure FreeWinsock(); 
    function Ping(IPAddr:String;TimeOut:Word):String; 
 
Const 
{ Exception Message } 
SInitFailed   = 'Winsock 版本错误'; 
SInvalidAddr  = '无效地IP地址'; 
SNoResponse   = '没有响应'; 
STimeOut      = '等待超时'; 
 
Type 
  TMainForm = class(TForm) 
    Memo: TMemo; 
    IPEdt: TEdit; 
    Button: TButton; 
    Timer1: TTimer; 
    procedure ButtonClick(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
  end; 
 
var 
  MainForm: TMainForm; 
  hICMP:THandle; 
implementation 
 
{$R *.DFM} 
procedure ValidCheck(); 
var 
  WSAData:TWSAData; 
begin 
  //initiates use of WS2_32.DLL 
  if (WSAStartup(MAKEWORD(2,0),WSAData)<>0) then 
    raise Exception.Create(SInitFailed); 
  hIcmp:=IcmpCreateFile(); 
  if hICMP=INVALID_HANDLE_VALUE then 
    raise Exception.Create('Create ICMP Failed'); 
end; 
procedure FreeWinsock(); 
begin 
  IcmpCloseHandle(hIcmp); 
  WSACleanUP; //结束ws2_32.dll的调用 
end; 
 
function Ping(IPAddr:String;TimeOut:Word):String; 
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; 
  temp:Integer; 
  pIPAddr:Pchar; 
begin 
  //get ip 
  GetMem(pIPAddr,Length(IPAddr)+1); 
  ZeroMemory(pIPAddr,Length(IPAddr)+1); 
  StrPCopy(pIPAddr,IPAddr); 
  //calc 
  FIPAddress := inet_addr(pIPAddr); //==转换IP地址== 
  //free it 
  FreeMem(pIPAddr); 
  //valid check 
  if FIPAddress=INADDR_NONE then 
  begin 
    result:=SInvalidAddr;//Exit 
    exit; 
  end; 
  //WSAAsyncGetHostByAddr() 
  //package size 
  FSize := 40; 
  BufferSize := SizeOf(TICMPEchoReply) + FSize; 
  GetMem(pRevData,FSize); 
  GetMem(pIPE,BufferSize); 
  //prepare data 
  FillChar(pIPE^, SizeOf(pIPE^), 0); 
  pIPE^.Data := pRevData; 
  MyString := 'Ping Digital Data'; 
  pReqData := PChar(MyString); 
  FillChar(IPOpt, Sizeof(IPOpt), 0); 
  //max delieve geteway 
  IPOpt.TTL := 64; 
  //time out 
  FTimeOut := TimeOut; 
  //go!!! 
  temp := IcmpSendEcho(hICMP,//dll handle 
                      FIPAddress,//target 
                      pReqData,//data 
                      Length(MyString),//data length 
                      @IPOpt,//addree of ping option 
                      pIPE,// 
                      BufferSize,//pack size 
                      FTimeOut);//timeout value 
  //check result 
  if temp=0 then 
  begin 
    Result:='Ping Addr:'+IPAddr+' '+SNoResponse; 
    exit; 
  end; 
  if pReqData^ = pIPE^.Options.OptionsData^ then 
  begin 
  //show result 
  Result:=('Reply from:'+PChar(IPAddr) + ' ' 
      +'bytes:'+IntToStr(pIPE^.DataSize) + ' ' 
      +'tims:'+IntToStr(pIPE^.RTT)+ 'ms ' 
      +'TTL:'+intToStr(pIPE^.Options.TTL)); 
  end; 
  //clear memory 
  FreeMem(pRevData); 
  FreeMem(pIPE); 
end; 
 
procedure TMainForm.ButtonClick(Sender: TObject); 
begin 
  Timer1.Enabled := True; 
end; 
 
procedure TMainForm.Timer1Timer(Sender: TObject); 
begin 
  ValidCheck(); 
  Memo.Lines.add(Ping(IPEdt.Text,500)); 
  FreeWinsock(); 
end; 
 
end.