|
发信人: 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  兄弟我抛出几块砖，有玉的赶紧亮出来啊！ |
|
[关闭][返回] |