精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● Delphi>>Delphi 网络编程>>[转载]Ping(Delphi代码)

主题:[转载]Ping(Delphi代码)
发信人: goodfrd(supervisor)
整理人: soaringbird(2002-10-16 17:20:40), 站内信件
Delphi ICMP Component V1.0
Written by: Stuart L. Richmond
[email protected]


Internet control message protocal (ICMP) is used primarily for determining host availability and routing information.  Early versions of winsock (1.1 and below) don't support the SOCK_RAW socket type, needed to create packets of this type.  Many early versions of Win95 are at the winsock 1.1 rev.  As a work around, Microsoft developed an unsupported DLL to send and receive ICMP packets.  The calls are blocking calls, and as I did not implement ICMP with threads, the Ping method below is blocking (maybe next time...)

ICMP is a component which accesses the unsupported ICMP dll.  The three functions in the DLL, icmpcreatefile, icmpsendecho, and icmpclosefile are used by the ICMP componant to implement a method named PING.

This control was built on Delphi 3.0, but should work in Delphi 2 (The Ping app won't work in 2 if Borland changed the format for DFM files).  ICMP will definitely not work with Delphi 1 (ICMP.DLL requires 32 bit extensions)

Installing the component

In the IDE, go to Component, then Install Component.  Use browse to find the ICMP.PAS unit file, and click ok.  The component will be compiled, when asked "Do you want to replace?" click OK.  You should now have the ICMP component on the Samples page.

Files in ICMP1.ZIP

ICMP.PAS File with ICMP unit source
ICMP.DCR Icon and Bitmap for ICMP control
ICMP.DCU Compiled unit
ICMP.DOC This file
PING.ZIP Example application using the ICMP control

Acknowledgements:
      Martien Verbruggen - Work describing access to ICMP.DLL
      Gary T. Desrosiers  - His layout of SOCKV3 control gives some great guidance on How To...

Version 1.0 May 1997

General Use
Set the TICMP.HostName or TICMP.Address property to the target node, and invoke TICMP.Ping (where TICMP would actually be the instance name in your code.)

TICMP.Ping will return a pointer to the echo reply if received, and nil if not.  Examine the status property if Nil is returned.  A reply record is defined as:

TIcmpEchoReply = packed record
Address: DWord; // replying address
Status: DWord; // IP status value
RTT: DWord; // Round Trip Time in milliseconds
DataSize: Word;  // reply data size
Reserved: Word;
Data: Pointer; // pointer to reply data buffer
Options: TIPOptionInformation;  // reply options
end;


Properties
HostName: String
Name or dotted address of target to ping

Address: DWord
IP address of target to ping (In_Addr)

TimeOut: DWord
Time (in milli-seconds) to wait for a response

HostIP: String
Dotted IP address of target node.  This parameter is set when TICMP.Ping is invoked.  Writing to it has no effect.

Phe: PHostEnt
HostEnt structure used during name resolution.

IPOptions: TIPOptionInformation
Options for the sendecho packet.

IPEchoReply: PIcmpEchoReply
Pointer to Echo Reply buffer received from remote node.

Status: integer
Status of last TICMP.Ping invocation
CICMP_NORMAL - Successful completion of call
CICMP_NO_RESPONSE - No response within timeout
CICMP_RESOLVE_ERROR - Hostname unknown

AlwaysResolve: Boolean
Sets behavior for name resolution.  If True, name will be resolved before every SendEcho call.  Default False, name is resolved only after HostName or Adress properties are written to.

Method
PING
Call icmpsendecho and return reply as pointer or Nil if no response or error.


The code in the included files are released to public domain.

Stuart L. Richmond
[email protected]

unit ICMP;
{
  Install this component using Component, Install Component, Add.
  This provides a simple interface to the ICMP dll.

  The code herein is released to the public domain without conditions.

  Written By:      Stuart L. Richmond
  Date:            May, 1997.
  Copyright:       (R) Copyright by Stuart L. Richmond, 1997.
                       All Rights Reserved
                   [email protected]

  Description:     This control performs ICMP calls.

  Prerequisites:   Delphi 3.  Actually, it should load under Delphi 2
                   if you have the TCP/IP protocol installed.  I've
                   only tested under Win95 with Delphi 3.

  Acknowledgements:
                   Martien Verbruggen - Work describing access to ICMP.DLL
                   Gary T. Desrosiers - His layout of SOCKV3 control gives
                                        some great guidance on How To...

Version 1.0 May 1997

General Use
        Set the TICMP.HostName or TICMP.Address property to the target node,
        and invoke TICMP.Ping

        TICMP.Ping will return a pointer to the echo reply if received,
        and nil if not.

Properties
    HostName: String
              Name or dotted address of target to ping

    Address: DWord
             IP address of target to ping (In_Addr)

    TimeOut: DWord
             Time (in milli-seconds) to wait for a response

    HostIP: String
            Dotted address of target node.  This parameter is set when
            TICMP.Ping is invoked.  Writing to it has no effect.

    Phe: PHostEnt
            HostEnt structure defined after call to TICMP.Ping

    IPOptions: TIPOptionInformation
            Options for the sendecho packet.

    IPEchoReply: PIcmpEchoReply
             Pointer to Echo Reply buffer received from remote node.

    Status: integer
             Status of last TICMP.Ping invocation
             CICMP_NORMAL - Successful completion of call
             CICMP_NO_RESPONSE - No response within timeout
             CICMP_RESOLVE_ERROR - Hostname unknown

    AlwaysResolve: Boolean
             Sets behavior for name resolution.  If True, name will be
             resolved before every SendEcho call.  Default False.
Method
    ping     Call icmpsendecho and return reply as pointer or Nil if
             no response or error.

}
interface

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

const
  CICMP_NORMAL      = 0;
  CICMP_NO_RESPONSE = 1;
  CICMP_RESOLVE_ERROR   = 2;

type

  PIPOptionInformation = ^TIPOptionInformation;
  TIPOptionInformation = packed record
     TTL:         Byte;      // Time To Live (used for traceroute)
     TOS:         Byte;      // Type Of Service (usually 0)
     Flags:       Byte;      // IP header flags (usually 0)
     OptionsSize: Byte;      // Size of options data (usually 0, max 40)
     OptionsData: PChar;     // Options data buffer
  end;

  PIcmpEchoReply = ^TIcmpEchoReply;
  TIcmpEchoReply = packed record
     Address:       DWord;                // replying address
     Status:        DWord;                // IP status value
     RTT:           DWord;                // Round Trip Time in milliseconds
     DataSize:      Word;                 // reply data size
     Reserved:      Word;
     Data:          Pointer;              // pointer to reply data buffer
     Options:       TIPOptionInformation; // reply options
  end;

    TIcmpCreateFile = function: THandle; stdcall;
    TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;
    TIcmpSendEcho = function(
     IcmpHandle:          THandle;
     DestAddress:         DWord;
     RequestData:         Pointer;
     RequestSize:         Word;
     RequestOptions:      PIPOptionInformation;
     ReplyBuffer:         Pointer;
     ReplySize:           DWord;
     Timeout:             DWord
    ): DWord; stdcall;

  Ticmp = class(TWinControl)
  private
    _wsadata: TWSAData;                  // Winsock init data
    _hICMPlib: HModule;                  // ICMP handle for DLL
    _IcmpCreateFile : TIcmpCreateFile;   // ICMP routine
    _IcmpCloseHandle: TIcmpCloseHandle;  // ICMP routine
    _IcmpSendEcho:    TIcmpSendEcho;     // ICMP routine
    _hICMP: THandle;                     // ICMP handle for calls
    _nPkts: Integer;                     // number of packets returned by sendecho
    _StaleName: Boolean;                // Hostname or Address modified

    _TimeOut : Integer;        // ICMP send timeout setting
    _Address: DWord;           // Address of host to contact
    _HostName: String;         // HostName for target node
    _HostIP: String;           // IP of target node
    _Phe: PHostEnt;            // HostEntry buffer for name lookup
    _IPOptions: TIPOptionInformation;  // IP Options for packet to send
    _pEchoReplyData: Pointer; // Pointer to sendecho data buffer initially $AA
    _EchoReplySize: integer;
    _EchoRequestSize: integer;
    _pEchoRequestData: Pointer;
    _pIPEchoReply: PIcmpEchoReply;               // ICMP Echo reply buffer
    _status: integer;
    _AlwaysResolve: Boolean;     // Resolve name every call if unchanged?
    { Private declarations }
    procedure ICMPError(errstr: string);
    function ResolveAddress: boolean;
    procedure TWMPaint(var msg:TWMPaint); message WM_PAINT;
    function Get_Address: DWord;
    procedure Set_Address(Address: DWord);
    function Get_HostName:String;
    procedure Set_HostName(HostName:String);
  protected
    { protected declerations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ping: pIcmpEchoReply;
  published
    property Address: DWord read Get_Address
                            write Set_Address;// Address of host to contact
    property HostName: String read Get_HostName
                              write Set_HostName;

    property TimeOut: DWord read _TimeOut
                            write _TimeOut;

    property HostIP: String read _HostIP
                            write _HostIP;// read only Dotted IP of host to contact
    property Phe: PHostEnt read _Phe
                           write _Phe;// HostEntry buffer for name lookup
    property IPOptions: TIPOptionInformation read _IPOptions
                                             write _IPOptions;// IP Options for packet to send
{
    property pEchoReplyData: Pointer read _pEchoReplyData
                                   write _pEchoReplyData; // Pointer to sendecho data buffer initially $AA
    property EchoReplySize: integer read _EchoReplySize
                                     write _EchoReplySize;
    property pEchoRequestData: Pointer read _pEchoRequestData
                                       write _pEchoRequestData;
    property EchoRequestSize: integer read _EchoRequestSize
                                      write _EchoRequestSize;
}
    property pIPEchoReply: PIcmpEchoReply read _pIPEchoReply
                                          write _pIPEchoReply; // ICMP Echo reply buffer

    property status: integer read _status
                             write _status;
    property AlwaysResolve: Boolean read _AlwaysResolve
                                    write _AlwaysResolve;

  end;

procedure Register;
{var}

implementation

const
  IcmpDLL = 'icmp.dll';

{ var }

procedure Register;
begin
  RegisterComponents('Samples', [TICMP]);
end;


constructor Ticmp.Create(AOwner: TComponent);
var
 rstat: integer;

begin
  inherited Create(AOwner);
  // initialize winsock, request at least 1.1
  rstat := WSAStartup($101,_wsadata);
  if rstat <> 0 then begin
      ICMPError('Error Initializing WinSock Stat:'+inttostr(rstat));
  end;

  // Load ICMP
  _hICMPlib := loadlibrary(icmpDLL);
  if _hICMPlib <> null then begin
    // initialize addresses to Icmp routines in library
    @_ICMPCreateFile := GetProcAddress(_hICMPlib, 'IcmpCreateFile');
    @_IcmpCloseHandle:= GetProcAddress(_hICMPlib, 'IcmpCloseHandle');
    @_IcmpSendEcho:= GetProcAddress(_hICMPlib, 'IcmpSendEcho');
    if (@_ICMPCreateFile = Nil) or
       (@_IcmpCloseHandle = Nil) or
       (@_IcmpSendEcho = Nil) then begin
      ICMPError('Error loading ICMP functions (one or more Nil)');
    end;
    // Create ICMP handle
    _hICMP := _IcmpCreateFile;
    if _hICMP = INVALID_HANDLE_VALUE then begin
      ICMPError('ICMPCreateFile failure: INVALID_HANDLE_VALUE');
    end;
  end else begin
    ICMPError('Unable to register ' + icmpDLL);
  end;
// Setup buffers used for ICMP packets
  FillChar(_IPOptions, SizeOf(_IPOptions), 0);
  _IPOptions.TTL := 64;

  _EchoRequestSize := 56;

  GetMem(_pEchoReplyData, _EchoRequestSize); // should get back what we send
  _EchoReplySize := SizeOf(TICMPEchoReply) + _EchoRequestSize;

  GetMem(_pEchoRequestData, _EchoRequestSize);
  GetMem(_pIPEchoReply, _EchoReplySize);
  FillChar(_pEchoRequestData^, _EchoRequestSize, $AA);
  _pIPEchoReply^.Data := _pEchoReplyData;

  _HostName := '';
  _HostIP := '';
  _Address := INADDR_NONE;
  _TimeOut := 3000;
  _AlwaysResolve := False;
  _StaleName := True;
  invalidate;
end;

destructor Ticmp.Destroy;
var
 rstat: integer;
begin
  // Free allocated memory
  FreeMem(_pIPEchoReply);
  FreeMem(_pEchoReplyData);
  FreeMem(_pEchoRequestData);
  // Close ICMP and free icmp.dll
  _IcmpCloseHandle(_hICMP);
  FreeLibrary(_hICMPlib);
  // Release Winsock
  rstat := WSACleanup;
  if rstat <> 0 then ICMPError('Error freeing winsock');
  inherited Destroy;
end;

function Ticmp.Get_HostName: string;
begin
  result:=_HostName;
end;

procedure Ticmp.Set_HostName(HostName: String);
begin
  _StaleName := True;
  _HostName := HostName;
  _HostIP := '';
  _Address := INADDR_NONE;
end;

function Ticmp.Get_Address: DWord;
begin
  result:=_Address;
end;

procedure Ticmp.Set_Address(Address:DWord);
begin
  _StaleName := True;
  _Address := Address;
  _HostName := StrPas(inet_ntoa(TInAddr(_Address)));
  _HostIP := StrPas(inet_ntoa(TInAddr(_Address)));
end;

function Ticmp.ResolveAddress: boolean;
{var}
begin
  if (_HostName = '') and (_Address=0) then result := False
  // If no HostName or Address, can't do lookup
  else if (not _AlwaysResolve) and (not _StaleName) then result := True
  else begin
    // See if the address was specified in #.#.#.# format
    _Address := inet_addr(PChar(_HostName));
    result := true;
    if (_Address = INADDR_NONE) then begin
      // Try to lookup up address in HostName
      _Phe := GetHostByName(PChar(_HostName));
      if _Phe = Nil then result := false
      else begin
        _StaleName := False;
        _Address := longint(plongint(_Phe^.h_addr_list^)^);
        _HostName := _Phe^.h_name;
        _HostIP := StrPas(inet_ntoa(TInAddr(_Address)));
      end;
    end else begin
      // Address was set, return ok even if gethostbyaddr fails
      // we don't require that they be in the DNS or hostname file, only
      // that we have an address to ping...
      _Phe := GetHostByAddr(@_Address, 4, AF_INET);
      if _Phe = Nil then begin
        _HostName := 'Name unavailable'
      end else begin
        _HostName := _Phe^.h_name;
      end;
      _StaleName := False;
      _HostIP := StrPas(inet_ntoa(TInAddr(_Address)));
    end;
  end;
end;

function TICMP.ping: pIcmpEchoReply;
{var  }
begin
  // Get/Set address to ping
  if ResolveAddress = True then begin
    // Send packet and block till timeout or response
    _NPkts := _IcmpSendEcho(_hICMP, _Address,
                            _pEchoRequestData, _EchoRequestSize,
                            @_IPOptions,
                            _pIPEchoReply, _EchoReplySize,
                           _TimeOut);
    if _NPkts = 0 then begin
      result := nil;
      status := CICMP_NO_RESPONSE;
    end else begin
      result := _pIPEchoReply;
    end;
  end else begin
    status := CICMP_RESOLVE_ERROR;
    result := nil;
  end;
end;

procedure TICMP.ICMPError(ErrStr: String);
var
  szLine: array[0..255]  of char;
begin
   StrPCopy(szLine,ErrStr);
   Application.MessageBox(szLine, 'ICMP ERROR', mb_OKCancel +
     mb_DefButton1);
   halt;
end;

procedure TICMP.TWMPaint(var msg: TWMPaint);
var
  icon: HIcon;
  dc: HDC;
begin
  if csDesigning in ComponentState then
  begin
    icon := LoadIcon(HInstance,MAKEINTRESOURCE('TICMP'));
    dc := GetDC(Handle);
    Width := 32;
    Height := 32;
    DrawIcon(dc,0,0,icon);
    ReleaseDC(Handle,dc);
    FreeResource(icon);
  end;
  ValidateRect(Handle,nil);
end;


end.



----
欢迎光临良友程序库:http://0d0a.126.com http://f12.my163.com,免费提供我的各种Source Code

兄弟我抛出几块砖,有玉的赶紧亮出来啊!
  

[关闭][返回]