unit PrjClassTCPHelper;
interface
uses
Windows,
WinSock,
SysUtils,
Classes;
function IsHostAlive( AHostname :
String;
var AErrorMessage :
string;
ApTripTime : PCardinal =
nil;
ATimeout : Integer = 1000;
ATTL : Integer = 255
): Boolean;
type
IP_OPTION_INFORMATION =
packed record
TTL : Byte;
TOS : Byte;
Flags : Byte;
OptionsSize : Byte;
OptionsData : PAnsiChar;
end;
PIP_OPTION_INFORMATION = ^IP_OPTION_INFORMATION;
ICMP_ECHO_REPLY =
packed record
Address : in_addr;
Status : Cardinal;
RoundTripTime : Cardinal;
DataSize : Word;
Reserved : Word;
Data : Pointer;
Options : IP_OPTION_INFORMATION;
end;
PICMP_ECHO_REPLY = ^ICMP_ECHO_REPLY;
function IcmpCreateFile: THandle;
stdcall;
external '
Iphlpapi.dll';
function IcmpCloseHandle(IcmpHandle: THandle): Boolean;
stdcall;
external '
Iphlpapi.dll';
function IcmpSendEcho( IcmpHandle : THandle;
DestinationAddress : Cardinal;
RequestData : Pointer;
RequestSize : Word;
RequestOptions : PIP_OPTION_INFORMATION;
ReplyBuffer : Pointer;
ReplySize : Cardinal;
Timeout : Cardinal
): Cardinal;
stdcall;
external '
Iphlpapi.dll';
implementation
//------------------------------------------------------------------------------
//- PrjClassTCPHelper.StringToPAnsiChar
//1 wandelt einen string in eine PAnsiChar
//- Params: stringVar : string
//- Result: PAnsiChar
function StringToPAnsiChar(stringVar :
string) : PAnsiChar;
var LAnsString : AnsiString;
var LInternalError : Boolean;
begin
LInternalError := false;
Result := '
';
try
if stringVar <> '
'
Then
begin
LAnsString := AnsiString(StringVar);
Result := PAnsiChar(PAnsiString(LAnsString));
end;
Except
LInternalError := true;
end;
end;
//------------------------------------------------------------------------------
//- PrjClassTCPHelper.ResolveHost
//1 löst den Hostname auf und gibt die IP Adresse zurück
//- Params: stringVar : string
//- Result: cardinal
function ResolveHost(AHostname : AnsiString): Cardinal;
var lHostInfo : PHostEnt;
var lIpAdress : ^PInAddr;
begin
Result := inet_addr(PAnsiChar(AHostname));
// ist AHostname schon eine IP Adresse dann ist result <> INADDR_NONE
if Result = INADDR_NONE
then begin
// AHostname auflösen und IP ermitteln
LHostInfo := gethostbyname(PAnsiChar(AHostname));
if Assigned(LHostInfo)
then
begin
lIpAdress := Pointer(lHostInfo^.h_addr_list);
if Assigned(lIpAdress)
and Assigned(lIpAdress^)
then
begin
Result := lIpAdress^^.S_addr;
end;
end;
end;
end;
//------------------------------------------------------------------------------
//- PrjClassTCPHelper.IsHostAlive
//1 senedet ein Ping an den Peer und wartet auf eine Antwort, gibt true zurück wenn eine Antwort kommt
//- Params: AHostname : String;var AErrorMessage : string; ATimeout, ATTL : Integer
//- Result: boolean
function IsHostAlive( AHostname :
String;
var AErrorMessage :
string;
ApTripTime : PCardinal;
ATimeout,
ATTL : Integer
): Boolean;
const SendBuffer :
array[0..31]
of AnsiChar = '
pingpongpingpongpingpongpingpong';
var WSA : TWSADATA;
var Reply : PICMP_ECHO_REPLY;
var Addr : Cardinal;
var hIcmp : THandle;
var Options : IP_OPTION_INFORMATION;
begin
Result := False;
FillChar(Options, SizeOf(IP_OPTION_INFORMATION), #0);
Options.TTL := ATTL;
Options.TOS := 1;
if WSAStartUp(((0
shl 8) + 2), WSA) = 0
then
begin
Addr := ResolveHost(AnsiString(AHostname));
if Addr <> INADDR_NONE
then
begin
hIcmp := IcmpCreateFile;
if hicmp <> INVALID_HANDLE_VALUE
then
begin
Reply :=
nil;
try
Reply := AllocMem(SizeOf(ICMP_ECHO_REPLY) + SizeOf(SendBuffer));
IcmpSendEcho(hIcmp, Addr, @SendBuffer[0], SizeOf(SendBuffer), @Options, Reply, SizeOf(ICMP_ECHO_REPLY) + SizeOf(SendBuffer), ATimeout);
Result := (Reply^.Status = 0);
if Result
and Assigned(ApTripTime)
then
begin
ApTripTime^ := Reply^.RoundTripTime;
end;
finally
IcmpCloseHandle(hIcmp);
if Assigned(Reply)
then
begin
FreeMem(Reply);
end;
WSACleanup;
end;
end else
begin
AErrorMessage := '
IcmpCreateFile not successfull';
end;
end else begin
// Hostname konnte nicht aufgelöst werden.
AErrorMessage := '
hostname could not be resolved';
WSACleanup;
end;
end else
begin
// Winsock konnte nicht gestartet werden.
AErrorMessage := '
winsock could not be started';
end;
end;
end.