发信人: 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
兄弟我抛出几块砖,有玉的赶紧亮出来啊! |
|