Zurück zur Homepage

Ping absetzen

Mit diesen Prozeduren können sie einen Ping absetzen, den Hostnamen einer IP-Adresse ermitteln, die IP eines Hosts ermitteln.

Beispieldatei (ping.zip 27 KB)

Option Explicit
Public Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const AF_INET As Long = 2

Private Type Hostent
  
 hName As Long
  
hAliases As Long
  
hAddrType As Integer
 
 hLen As Integer
  
hAddrList As Long
End Type

Private Type WSAdata
  
wVersion As Integer
 
 wHighVersion As Integer
  
szDescription(0 To MAX_WSADescription) As Byte
  
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
  
iMaxSockets As Integer
 
 iMaxUdpDg As Integer
  
lpVendorInfo As Long
End Type  

Private Type IP_OPTION_INFORMATION
 
 TTL As Byte
  
Tos As Byte
  
Flags As Byte
  
OptionsSize As Long
  
OptionsData As String * 128
End Type

Private Type IP_ECHO_REPLY
  
Address(0 To 3) As Byte
  
Status As Long
  
RoundTripTime As Long
  
DataSize As Integer
  
Reserved As Integer
  
data As Long
  
Options As IP_OPTION_INFORMATION
End Type

Private Declare Function gethostbyaddr _
  
Lib "WSOCK32" _
  
(szHost As Any, _
  
ByVal dwHostLen As Integer, _
  
dwSocketType As Integer) As Long

Private Declare Function GetHostByName _
  
Lib "wsock32.dll" Alias "gethostbyname" _
  
(ByVal Hostname As String) As Long

Private Declare Function WSAStartup _
  
Lib "WSOCK32" _
  
(ByVal wVersionRequired As Long, _
  
lpWSAdata As WSAdata) As Long

Private Declare Function WSACleanup _
  
Lib "wsock32.dll" _
  
() As Long

Private Declare Sub CopyMemory _
  
Lib "kernel32" Alias "RtlMoveMemory" _
  
(hpvDest As Any, _
  
ByVal hpvSource As Long, _
  
ByVal cbCopy As Long)

Private Declare Function inet_addr _
  
Lib "WSOCK32" _
  
(ByVal cp As String) 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" _
  
(ByVal IcmpHandle As Long, _
  
ByVal DestAddress As Long, _
  
ByVal RequestData As String, _
  
ByVal RequestSize As Integer, _
  
RequestOptns As IP_OPTION_INFORMATION, _
  
ReplyBuffer As IP_ECHO_REPLY, _
  
ByVal ReplySize As Long, _
  
ByVal TimeOut As Long) _
  
As Boolean

 Private Type LngIP
  
LngIP As Long
End Type

 

Private Type IP
  
Byte4 As Byte
  
Byte3 As Byte
  
Byte2 As Byte
  
Byte1 As Byte
End Type

Sub test()
Dim Hoststring As String
  
Hoststring = "t-online.de"
  
MsgBox "IP als Long " & Lng_IP_von_Hostname(Hoststring)
  
MsgBox Hoststring
  
MsgBox Hostname_von_IP(Hoststring)
  
MsgBox "Antwort nach " + _
  
CStr(VbaPingen(Hoststring)) + " ms"
End Sub

Public Function VbaPingen(HostIp As String) As Long
Dim hlngFile As Long
Dim OptInfo As IP_OPTION_INFORMATION
Dim EchoReply As IP_ECHO_REPLY
Dim LngHostIP As Long
Dim strRequestData As String
Dim lngTimeout As Long
  
'String IP nach Long umwandeln
  
LngHostIP = Lng_IP_von_IP(HostIp)
  
If Not Initialisierung() Then Exit Function
  
strRequestData = String(32, "x")
  
lngTimeout = 3000
  
hlngFile = IcmpCreateFile()
  
OptInfo.TTL = 255
  
If IcmpSendEcho(hlngFile, LngHostIP, _
    
strRequestData, Len(strRequestData), _
    
OptInfo, EchoReply, Len(EchoReply) + 8, _
    
lngTimeout) Then
    
With EchoReply
      
VbaPingen = .RoundTripTime
      
'        MsgBox "RoundTripTime " & CStr(.RoundTripTime)
      
'        MsgBox "LngHostIP " & CStr(LngHostIP)
      
'        MsgBox "Adress " & CStr(.Address)
      
'        MsgBox "Data " & CStr(.data)
      
'        MsgBox "DataSize " & CStr(.DataSize)
      
'        MsgBox "Status " & CStr(.Status)
      
'        MsgBox "TTL " & CStr(.Options.TTL)
    
End With
  
End If
  
IcmpCloseHandle hlngFile
  
WSACleanup
End Function

Private Function Initialisierung() As Boolean
Dim udtWSAData As WSAdata
  
If WSAStartup(MIN_SOCKETS_REQD, udtWSAData) = SOCKET_ERROR Then
    
Initialisierung = False
    
Exit Function
  
End If
  
Initialisierung = True
End Function

Private Function Lng_IP_von_IP(ByVal strIP As String) As Long
Dim IP As IP, LIP As LngIP
  
On Error Resume Next
  
IP.Byte4 = CLng(Left$(strIP, InStr(1, strIP, ".") - 1))
  
strIP = Right$(strIP, Len(strIP) - InStr(1, strIP, "."))
  
IP.Byte3 = CLng(Left$(strIP, InStr(1, strIP, ".") - 1))
  
strIP = Right$(strIP, Len(strIP) - InStr(1, strIP, "."))
  
IP.Byte2 = CLng(Left$(strIP, InStr(1, strIP, ".") - 1))
  
strIP = Right$(strIP, Len(strIP) - InStr(1, strIP, "."))
  
IP.Byte1 = CLng(strIP)
  
LSet LIP = IP
  
Lng_IP_von_IP = LIP.LngIP
End Function

Public Function Lng_IP_von_Hostname(Hoststring As String) As Long
'Wenn Hoststring als Referenz übergeben wurde, dann
'wird IP als Hoststring in gewohnter Notation
'zurückgegeben (192.168.100.2)
Dim strHostname As String * 256
Dim lp_to_Hostent As Long
Dim IP_von_Hostname As String
Dim udtHost As Hostent
Dim LngIP As Long
Dim buffer(1 To 4) As Byte
Dim a As Long
On Error Resume Next
  
If Not Initialisierung() Then Exit Function
  
strHostname = Hoststring & vbNullChar
  
Hoststring = ""
  
lp_to_Hostent = GetHostByName(strHostname)
  
If lp_to_Hostent = 0 Then
    
WSACleanup
    
Exit Function
  
End If
  
With udtHost
    
CopyMemory udtHost, lp_to_Hostent, Len(udtHost)
    
CopyMemory LngIP, .hAddrList, 4
   
 CopyMemory buffer(1), LngIP, 4
    
CopyMemory Lng_IP_von_Hostname, LngIP, 4
    
For a = 1 To 4
     
Hoststring = Hoststring _
       
& buffer(a) & "."
     
Next
     
Hoststring = Left$(Hoststring, Len(Hoststring) - 1)
  
End With
  
WSACleanup
End Function

Public Function Hostname_von_IP(ByVal IP_String As String) _
  
As String
Dim lngNetwByteOrder As Long
Dim lp_to_Hostent As Long
Dim udtHost As Hostent
Dim buffer(1 To 4) As Byte
  
If Not Initialisierung() Then Exit Function
  
lngNetwByteOrder = inet_addr(IP_String)
  
CopyMemory buffer(1), VarPtr(lngNetwByteOrder), 4
  
lp_to_Hostent = gethostbyaddr(buffer(1), 4, AF_INET)
  
If lp_to_Hostent = 0 Then WSACleanup: Exit Function
  
CopyMemory udtHost, lp_to_Hostent, Len(udtHost)
  
Hostname_von_IP = String(256, 0)
  
CopyMemory ByVal Hostname_von_IP, udtHost.hName, 255
  
Hostname_von_IP = Left$(Hostname_von_IP, _
    
InStr(1, Hostname_von_IP, vbNullChar) - 1)
  
WSACleanup
End Function