純api實現ping主機（僅僅返回是否ping通）

modPing.bas

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