Thomas Risi Softwareentwicklung

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

Bewerten Sie bitte dieses Programm.
1 2 3 4 5
Weniger nützlich Sehr nützlich
Bitte teilen Sie uns mit, warum Sie das Programm so bewertet haben. (optional)