Thomas Risi Softwareentwicklung
Addins - Datenbanklösungen - Komponenten - RTDServer - WebServices
Ping
Eine (VB)Funktion zum Pingen ...
Option Explicit
Private Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" ( _
ByVal Hostname As String) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" ( _
ByVal wVersionRequired&, lpWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" ( _
ByVal HANDLE As Long) As Boolean
Private Declare Function IcmpSendEcho Lib "icmp.dll" ( _
ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Long, _
ByVal RequestOptions As Long, _
ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, _
ByVal TIMEOUT As Long) As Long
Private Type WSAdata
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 255) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Type Hostent
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type
Public Type IP_OPTION_INFORMATION
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Public Type ICMP_ECHO_REPLY
Address(0 To 3) As Byte
status As Long
RoundTripTime As Long
datasize As Long
DataPointer As Long
Options As IP_OPTION_INFORMATION
Data As String * 250
End Type
Private Const SOCKET_ERROR = 0
Private Const WSA_SUCCESS = 0
Public Function Ping(ByVal Server As String) As Boolean
Dim hFile As Long
Dim hHostent As Hostent, AddrList As Long, Address As Long
Dim EchoReply As ICMP_ECHO_REPLY
Const SENDDATA As String = "PINGDATAMESSAGE"
Const TIMEOUT As Long = 200
If Left(Server, 7) = "http://" Then _
Server = Mid(Server, 8)
If SocketsInitialize Then
If GetHostByName(Server + String(64 - Len(Server), 0)) <> SOCKET_ERROR Then
CopyMemory hHostent.h_name, ByVal GetHostByName(Server + String(64 - Len(Server), 0)), Len(hHostent)
CopyMemory AddrList, ByVal hHostent.h_addr_list, 4
CopyMemory Address, ByVal AddrList, 4
End If
hFile = IcmpCreateFile()
If hFile = 0 Then _
Exit Function
Call IcmpSendEcho(hFile, Address, SENDDATA, Len(SENDDATA), 0, EchoReply, Len(EchoReply) + 8, TIMEOUT)
If EchoReply.status = 0 Then _
Ping = True
Call SocketsCleanup
End If
End Function
Private Function SocketsInitialize() As Boolean
Dim WSAD As WSAdata
SocketsInitialize = WSAStartup(&H101, WSAD) = WSA_SUCCESS
End Function
Private Sub SocketsCleanup()
WSACleanup
End Sub
Sub TEST()
MsgBox Ping("localhost")
End Sub
© 2001 -
by Thomas Risi