modPing.bas
Attribute VB_Name = "modPing" 'modPing 'MsgBox IPValid("10.167.133.205") Option Explicit Private Const IP_STATUS_BASE = 11000 Private Const IP_SUCCESS = 0 Private Const IP_BUF_TOO_SMALL = (11000 + 1) Private Const IP_DEST_NET_UNREACHABLE = (11000 + 2) Private Const IP_DEST_HOST_UNREACHABLE = (11000 + 3) Private Const IP_DEST_PROT_UNREACHABLE = (11000 + 4) Private Const IP_DEST_PORT_UNREACHABLE = (11000 + 5) Private Const IP_NO_RESOURCES = (11000 + 6) Private Const IP_BAD_OPTION = (11000 + 7) Private Const IP_HW_ERROR = (11000 + 8) Private Const IP_PACKET_TOO_BIG = (11000 + 9) Private Const IP_REQ_TIMED_OUT = (11000 + 10) Private Const IP_BAD_REQ = (11000 + 11) Private Const IP_BAD_ROUTE = (11000 + 12) Private Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13) Private Const IP_TTL_EXPIRED_REASSEM = (11000 + 14) Private Const IP_PARAM_PROBLEM = (11000 + 15) Private Const IP_SOURCE_QUENCH = (11000 + 16) Private Const IP_OPTION_TOO_BIG = (11000 + 17) Private Const IP_BAD_DESTINATION = (11000 + 18) Private Const IP_ADDR_DELETED = (11000 + 19) Private Const IP_SPEC_MTU_CHANGE = (11000 + 20) Private Const IP_MTU_CHANGE = (11000 + 21) Private Const IP_UNLOAD = (11000 + 22) Private Const IP_ADDR_ADDED = (11000 + 23) Private Const IP_GENERAL_FAILURE = (11000 + 50) Private Const MAX_IP_STATUS = 11000 + 50 Private Const IP_PENDING = (11000 + 255) Private Const PING_TIMEOUT = 200 Private Const WS_VERSION_REQD = &H101 Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF& Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF& Private Const MIN_SOCKETS_REQD = 1 Private Const SOCKET_ERROR = -1 Private Const MAX_WSADescription = 256 Private Const MAX_WSASYSStatus = 128 Private Type ICMP_OPTIONS Ttl As Byte Tos As Byte Flags As Byte OptionsSize As Byte OptionsData As Long End Type Dim ICMPOPT As ICMP_OPTIONS Private Type ICMP_ECHO_REPLY Address As Long status As Long RoundTripTime As Long DataSize As Integer Reserved As Integer DataPointer As Long Options As ICMP_OPTIONS Data As String * 250 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 wMaxSockets As Integer wMaxUDPDG As Integer dwVendorInfo As Long End Type Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long Private Declare Function IcmpCloseHandle Lib "icmp.dll" _ (ByVal IcmpHandle As Long) _ As Long Private Declare Function IcmpSendEcho Lib "icmp.dll" _ (ByVal IcmpHandle As Long, _ ByVal DestinationAddress As Long, _ ByVal RequestData As String, _ ByVal RequestSize As Integer, _ ByVal RequestOptions As Long, _ ReplyBuffer As ICMP_ECHO_REPLY, _ ByVal ReplySize As Long, _ ByVal Timeout As Long) _ As Long Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long Private Declare Function WSAStartup Lib "WSOCK32.DLL" _ (ByVal wVersionRequired As Long, _ lpWSADATA As WSADATA) _ As Long Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long Private Function GetStatusCode(status As Long) As String Dim msg As String Select Case status Case IP_SUCCESS: msg = "ip success" Case IP_BUF_TOO_SMALL: msg = "ip buf too_small" Case IP_DEST_NET_UNREACHABLE: msg = "ip dest net unreachable" Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable" Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable" Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable" Case IP_NO_RESOURCES: msg = "ip no resources" Case IP_BAD_OPTION: msg = "ip bad option" Case IP_HW_ERROR: msg = "ip hw_error" Case IP_PACKET_TOO_BIG: msg = "ip packet too_big" Case IP_REQ_TIMED_OUT: msg = "ip req timed out" Case IP_BAD_REQ: msg = "ip bad req" Case IP_BAD_ROUTE: msg = "ip bad route" Case IP_TTL_EXPIRED_TRANSIT: msg = "ip ttl expired transit" Case IP_TTL_EXPIRED_REASSEM: msg = "ip ttl expired reassem" Case IP_PARAM_PROBLEM: msg = "ip param_problem" Case IP_SOURCE_QUENCH: msg = "ip source quench" Case IP_OPTION_TOO_BIG: msg = "ip option too_big" Case IP_BAD_DESTINATION: msg = "ip bad destination" Case IP_ADDR_DELETED: msg = "ip addr deleted" Case IP_SPEC_MTU_CHANGE: msg = "ip spec mtu change" Case IP_MTU_CHANGE: msg = "ip mtu_change" Case IP_UNLOAD: msg = "ip unload" Case IP_ADDR_ADDED: msg = "ip addr added" Case IP_GENERAL_FAILURE: msg = "ip general failure" Case IP_PENDING: msg = "ip pending" Case PING_TIMEOUT: msg = "ping timeout" Case Else: msg = "unknown msg returned" End Select GetStatusCode = CStr(status) & " [ " & msg & " ]" End Function Private Function HiByte(ByVal wParam As Integer) HiByte = wParam \ &H100 And &HFF& End Function Private Function LoByte(ByVal wParam As Integer) LoByte = wParam And &HFF& End Function Private Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As Long Dim hPort As Long Dim dwAddress As Long Dim sDataToSend As String Dim iOpt As Long sDataToSend = "My Request" dwAddress = AddressStringToLong(szAddress) Call SocketsInitialize hPort = IcmpCreateFile() If IcmpSendEcho(hPort, _ dwAddress, _ sDataToSend, _ Len(sDataToSend), _ 0, _ ECHO, _ Len(ECHO), _ PING_TIMEOUT) Then Ping = ECHO.RoundTripTime Else: Ping = ECHO.status * -1 End If Call IcmpCloseHandle(hPort) Call SocketsCleanup End Function Function AddressStringToLong(ByVal tmp As String) As Long Dim i As Integer Dim parts(1 To 4) As String i = 0 While InStr(tmp, ".") > 0 i = i + 1 parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1) tmp = Mid(tmp, InStr(tmp, ".") + 1) Wend i = i + 1 parts(i) = tmp If i <> 4 Then AddressStringToLong = 0 Exit Function End If AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _ Right("00" & Hex(parts(3)), 2) & _ Right("00" & Hex(parts(2)), 2) & _ Right("00" & Hex(parts(1)), 2)) End Function Private Function SocketsCleanup() As Boolean Dim X As Long X = WSACleanup() If X <> 0 Then MsgBox "Windows Sockets error " & Trim$(Str$(X)) & _ " occurred in Cleanup.", vbExclamation SocketsCleanup = False Else SocketsCleanup = True End If End Function Private Function SocketsInitialize() As Boolean Dim WSAD As WSADATA Dim X As Integer Dim szLoByte As String, szHiByte As String, szBuf As String X = WSAStartup(WS_VERSION_REQD, WSAD) If X <> 0 Then MsgBox "Windows Sockets for 32 bit Windows " & _ "environments is not successfully responding." SocketsInitialize = False Exit Function End If If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _ (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _ HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then szHiByte = Trim$(Str$(HiByte(WSAD.wVersion))) szLoByte = Trim$(Str$(LoByte(WSAD.wVersion))) szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte szBuf = szBuf & " is not supported by Windows " & _ "Sockets for 32 bit Windows environments." MsgBox szBuf, vbExclamation SocketsInitialize = False Exit Function End If If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then szBuf = "This application requires a minimum of " & _ Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets." MsgBox szBuf, vbExclamation SocketsInitialize = False Exit Function End If SocketsInitialize = True End Function Public Function IPValid(ip As String) As Boolean SocketsInitialize Dim ECHO As ICMP_ECHO_REPLY Ping Trim(ip), ECHO If ECHO.DataSize <> 0 Then IPValid = True Else IPValid = False SocketsCleanup End Function