一个类似ping的程序,只要有信息返回,证明相同
unit Unit1;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, winsock;type
TForm1 = class(TForm)
Memo1: TMemo;
Label1: TLabel;
Edit1: TEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
procedure ShowError(error: Integer);
public
{ Public declarations }
end; 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 (see below)
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;
DestinationAddress: DWord;
RequestData: Pointer;
RequestSize: Word;
RequestOptions: PIPOptionInformation;
ReplyBuffer: Pointer;
ReplySize: DWord;
Timeout: DWord
): DWord; stdcall;var
Form1: TForm1;implementation{$R *.DFM}const
IcmpDLL = 'icmp.dll';var
hICMPlib: HModule;
IcmpCreateFile : TIcmpCreateFile;
IcmpCloseHandle: TIcmpCloseHandle;
IcmpSendEcho: TIcmpSendEcho;
hICMP: THandle; // Handle for the ICMP Callsprocedure TForm1.FormCreate(Sender: TObject);
var
wsadata: TWSAData;
begin
// initialise winsock
if WSAStartup($101,wsadata) <> 0 then begin
ShowMessage('Error initialising Winsock');
halt;
end; // register the icmp.dll stuff
hICMPlib := loadlibrary(icmpDLL);
if hICMPlib <> null then begin
@ICMPCreateFile := GetProcAddress(hICMPlib, 'IcmpCreateFile');
@IcmpCloseHandle:= GetProcAddress(hICMPlib, 'IcmpCloseHandle');
@IcmpSendEcho:= GetProcAddress(hICMPlib, 'IcmpSendEcho');
if (@ICMPCreateFile = Nil) or (@IcmpCloseHandle = Nil) or (@IcmpSendEcho = Nil) then begin
ShowMessage('Error loading dll functions');
halt;
end;
hICMP := IcmpCreateFile;
if hICMP = INVALID_HANDLE_VALUE then begin
ShowMessage('Unable to get ping handle');
halt;
end;
end
else begin
ShowMessage('Unable to register ' + icmpDLL);
halt;
end;
end;procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
// Free icmp.dll
IcmpCloseHandle(hICMP);
FreeLibrary(hICMPlib);
// free winsock
if WSACleanup <> 0 then ShowMessage('Error freeing winsock');
end;procedure TForm1.Button1Click(Sender: TObject);
const
Size = 56;
TimeOut = 3000;
var
Address: DWord; // Address of host to contact
HostName, HostIP: String; // Name and dotted IP of host to contact
Phe: PHostEnt; // HostEntry buffer for name lookup
BufferSize, nPkts: Integer;
pReqData, pData: Pointer;
pIPE: PIcmpEchoReply; // ICMP Echo reply buffer
IPOpt: TIPOptionInformation; // IP Options for packet to send
begin
// Do a lookup Address := inet_addr(PChar(Edit1.Text)); if (Address = INADDR_NONE) then begin
Phe := GetHostByName(PChar(Edit1.Text));
if Phe = Nil then ShowError(WSAGetLastError)
else begin
Address := longint(plongint(Phe^.h_addr_list^)^);
HostName := Phe^.h_name;
HostIP := StrPas(inet_ntoa(TInAddr(Address)));
end;
end
else begin
Phe := GetHostByAddr(@Address, 4, PF_INET);
if Phe = Nil then ShowError(WSAGetLastError)
else begin
HostName := Phe^.h_name;
HostIP := StrPas(inet_ntoa(TInAddr(Address)));
end;
end; if Address = INADDR_NONE then begin
Memo1.Lines.Add('Cannot resolve hostname ' + Edit1.Text);
end
else
begin
Memo1.Lines.Add('Sending ' + IntToStr(Size) + ' bytes to ' +
HostName + ' (' + HostIP + ')'); // Get some data buffer space and put something in the packet to send
BufferSize := SizeOf(TICMPEchoReply) + Size;
GetMem(pReqData, Size);
GetMem(pData, Size);
GetMem(pIPE, BufferSize);
FillChar(pReqData^, Size, $AA);
pIPE^.Data := pData; // Finally Send the packet
FillChar(IPOpt, SizeOf(IPOpt), 0);
IPOpt.TTL := 64;
NPkts := IcmpSendEcho(hICMP, Address, pReqData, Size,
@IPOpt, pIPE, BufferSize, TimeOut);
if NPkts = 0 then ShowError(GetLastError)
else
begin
//ShowMessage('ok');
HostIP := StrPas(inet_ntoa(TInAddr(pIPE^.Address)));
Memo1.Lines.Add('Received ' + IntToStr(pIPE^.DataSize) +
' bytes from ' + HostIP +
' in ' + IntToStr(pIPE^.RTT) + ' msecs')
end; // Free those buffers
FreeMem(pIPE);
FreeMem(pData);
FreeMem(pReqData);
end;
end;procedure TForm1.ShowError(error: integer);
begin
Memo1.Lines.Add('Error: ' + IntToStr(error));
end;end.
unit Unit1;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, winsock;type
TForm1 = class(TForm)
Memo1: TMemo;
Label1: TLabel;
Edit1: TEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
procedure ShowError(error: Integer);
public
{ Public declarations }
end; 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 (see below)
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;
DestinationAddress: DWord;
RequestData: Pointer;
RequestSize: Word;
RequestOptions: PIPOptionInformation;
ReplyBuffer: Pointer;
ReplySize: DWord;
Timeout: DWord
): DWord; stdcall;var
Form1: TForm1;implementation{$R *.DFM}const
IcmpDLL = 'icmp.dll';var
hICMPlib: HModule;
IcmpCreateFile : TIcmpCreateFile;
IcmpCloseHandle: TIcmpCloseHandle;
IcmpSendEcho: TIcmpSendEcho;
hICMP: THandle; // Handle for the ICMP Callsprocedure TForm1.FormCreate(Sender: TObject);
var
wsadata: TWSAData;
begin
// initialise winsock
if WSAStartup($101,wsadata) <> 0 then begin
ShowMessage('Error initialising Winsock');
halt;
end; // register the icmp.dll stuff
hICMPlib := loadlibrary(icmpDLL);
if hICMPlib <> null then begin
@ICMPCreateFile := GetProcAddress(hICMPlib, 'IcmpCreateFile');
@IcmpCloseHandle:= GetProcAddress(hICMPlib, 'IcmpCloseHandle');
@IcmpSendEcho:= GetProcAddress(hICMPlib, 'IcmpSendEcho');
if (@ICMPCreateFile = Nil) or (@IcmpCloseHandle = Nil) or (@IcmpSendEcho = Nil) then begin
ShowMessage('Error loading dll functions');
halt;
end;
hICMP := IcmpCreateFile;
if hICMP = INVALID_HANDLE_VALUE then begin
ShowMessage('Unable to get ping handle');
halt;
end;
end
else begin
ShowMessage('Unable to register ' + icmpDLL);
halt;
end;
end;procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
// Free icmp.dll
IcmpCloseHandle(hICMP);
FreeLibrary(hICMPlib);
// free winsock
if WSACleanup <> 0 then ShowMessage('Error freeing winsock');
end;procedure TForm1.Button1Click(Sender: TObject);
const
Size = 56;
TimeOut = 3000;
var
Address: DWord; // Address of host to contact
HostName, HostIP: String; // Name and dotted IP of host to contact
Phe: PHostEnt; // HostEntry buffer for name lookup
BufferSize, nPkts: Integer;
pReqData, pData: Pointer;
pIPE: PIcmpEchoReply; // ICMP Echo reply buffer
IPOpt: TIPOptionInformation; // IP Options for packet to send
begin
// Do a lookup Address := inet_addr(PChar(Edit1.Text)); if (Address = INADDR_NONE) then begin
Phe := GetHostByName(PChar(Edit1.Text));
if Phe = Nil then ShowError(WSAGetLastError)
else begin
Address := longint(plongint(Phe^.h_addr_list^)^);
HostName := Phe^.h_name;
HostIP := StrPas(inet_ntoa(TInAddr(Address)));
end;
end
else begin
Phe := GetHostByAddr(@Address, 4, PF_INET);
if Phe = Nil then ShowError(WSAGetLastError)
else begin
HostName := Phe^.h_name;
HostIP := StrPas(inet_ntoa(TInAddr(Address)));
end;
end; if Address = INADDR_NONE then begin
Memo1.Lines.Add('Cannot resolve hostname ' + Edit1.Text);
end
else
begin
Memo1.Lines.Add('Sending ' + IntToStr(Size) + ' bytes to ' +
HostName + ' (' + HostIP + ')'); // Get some data buffer space and put something in the packet to send
BufferSize := SizeOf(TICMPEchoReply) + Size;
GetMem(pReqData, Size);
GetMem(pData, Size);
GetMem(pIPE, BufferSize);
FillChar(pReqData^, Size, $AA);
pIPE^.Data := pData; // Finally Send the packet
FillChar(IPOpt, SizeOf(IPOpt), 0);
IPOpt.TTL := 64;
NPkts := IcmpSendEcho(hICMP, Address, pReqData, Size,
@IPOpt, pIPE, BufferSize, TimeOut);
if NPkts = 0 then ShowError(GetLastError)
else
begin
//ShowMessage('ok');
HostIP := StrPas(inet_ntoa(TInAddr(pIPE^.Address)));
Memo1.Lines.Add('Received ' + IntToStr(pIPE^.DataSize) +
' bytes from ' + HostIP +
' in ' + IntToStr(pIPE^.RTT) + ' msecs')
end; // Free those buffers
FreeMem(pIPE);
FreeMem(pData);
FreeMem(pReqData);
end;
end;procedure TForm1.ShowError(error: integer);
begin
Memo1.Lines.Add('Error: ' + IntToStr(error));
end;end.
解决方案 »
- 物流装配的系统中重要的数据库设计,200分求设计方案!!
- 这个又怎样的解决
- 关于主窗口大小设置的问题
- 如何在delphi7中添加FastNet页
- FastReport分栏问题?
- 如何将一个自定义结构写入一个Tstream类中,还有从Tstream中读取数据到自定义结构?
- 开始学delphi,大家用的是delphi7还是6?
- 我會powerbuilder,能否介紹一本好的delphi入門的電子讀物。謝謝
- delphi 7 .net preview的用法?
- 对 Delphi的前途好担忧.请大家讨论(进者有分)
- 高分相送!!!
- 如何在程序中访问ActionList中某个action如append的Enabled属性?回答马上给分
uses
Windows, SysUtils, Registry, WinSock, WinInet; type
TConnectionType = (ctNone, ctProxy, ctDialup); function ConnectedToInternet : TConnectionType;
function RasConnectionCount : Integer;
implementation //For RasConnectionCount =======================
const
cERROR_BUFFER_TOO_SMALL = 603;
cRAS_MaxEntryName = 256;
cRAS_MaxDeviceName = 128;
cRAS_MaxDeviceType = 16;
type
ERasError = class(Exception); HRASConn = DWord;
PRASConn = ^TRASConn;
TRASConn = record
dwSize: DWORD;
rasConn: HRASConn;
szEntryName: Array[0..cRAS_MaxEntryName] Of Char;
szDeviceType : Array[0..cRAS_MaxDeviceType] Of Char;
szDeviceName : Array [0..cRAS_MaxDeviceName] of char;
end; TRasEnumConnections =
function (RASConn: PrasConn; { buffer to receive Connections data }
var BufSize: DWord; { size in bytes of buffer }
var Connections: DWord { number of Connections written to buffer }
): LongInt; stdcall;
//End RasConnectionCount =======================
function ConnectedToInternet: TConnectionType;
var
Reg : TRegistry;
bUseProxy : Boolean;
UseProxy : LongWord;
begin
Result := ctNone;
Reg := TRegistry.Create;
with REG do
try
try
RootKey := HKEY_CURRENT_USER;
if OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet settings',False) then begin
//I just try to read it, and trap an exception
if GetDataType('ProxyEnable') = rdBinary then
ReadBinaryData('ProxyEnable', UseProxy, SizeOf(LongWord) )
else begin
bUseProxy := ReadBool('ProxyEnable');
if bUseProxy then
UseProxy := 1
else
UseProxy := 0;
end;
if (UseProxy <> 0) and ( ReadString('ProxyServer') <> '' ) then Result := ctProxy;
end;
except
//Obviously not connected through a proxy
end;
finally
Free;
end; //We can check RasConnectionCount even if dialup networking is not installed
//simply because it will return 0 if the DLL is not found.
if Result = ctNone then begin
if RasConnectionCount > 0 then Result := ctDialup;
end;
end; function RasConnectionCount : Integer;
var
RasDLL : HInst;
Conns : Array[1..4] of TRasConn;
RasEnums : TRasEnumConnections;
BufSize : DWord;
NumConns : DWord;
RasResult : Longint;
begin
Result := 0; //Load the RAS DLL
RasDLL := LoadLibrary('rasapi32.dll');
if RasDLL = 0 then exit; try
RasEnums := GetProcAddress(RasDLL,'RasEnumConnectionsA');
if @RasEnums = nil then
raise ERasError.Create('RasEnumConnectionsA not found in rasapi32.dll'); Conns[1].dwSize := Sizeof (Conns[1]);
BufSize := SizeOf(Conns); RasResult := RasEnums(@Conns, BufSize, NumConns); If (RasResult = 0) or (Result = cERROR_BUFFER_TOO_SMALL) then Result := NumConns;
finally
FreeLibrary(RasDLL);
end;
end;