VB6之ICMP实现ping功能

代码备忘

 'code by lichmama from cnblogs.com
 Private Type IPAddr
     ip1 As Byte
     ip2 As Byte
     ip3 As Byte
     ip4 As Byte
 End Type

 Private Type IP_OPTION_INFORMATION
     Ttl As Byte
     Tos As Byte
     Flags As Byte
     OptionsSize As Byte
     OptionsData As Long
 End Type

 Private Type ICMP_ECHO_REPLY
     Address As IPAddr
     Status As Long
     RoundTripTime As Long
     DataSize As Integer
     Reserved As Integer
     ptrData As Long
     Options As IP_OPTION_INFORMATION
     Data As String *
 End Type

 Private Const REQUEST_TIMEOUT = 

 Private Declare Sub RtlZeroMemory Lib "KERNEL32" (dest As Any, ByVal numBytes As Long)
 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 Long, _
     ByVal RequestOptions As Long, _
     ReplyBuffer As ICMP_ECHO_REPLY, _
     ByVal ReplySize As Long, _
     ByVal timeout As Long) As Long

 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 =
 Private Const SOCKET_ERROR = -
 Private Const WSADescription_Len =
 Private Const WSASYS_Status_Len = 

 Private Type HOSTENT
     hName As Long
     hAliases As Long
     hAddrType As Integer
     hLength As Integer
     hAddrList As Long
 End Type

 Private Type WSADATA
     wversion As Integer
     wHighVersion As Integer
     szDescription( To WSADescription_Len) As Byte
     szSystemStatus( To WSASYS_Status_Len) As Byte
     iMaxSockets As Integer
     iMaxUdpDg As Integer
     lpszVendorInfo As Long
 End Type

 Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
 Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Integer, _
     lpwsadata As WSADATA) As Long
 Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
 Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal hostname As String, _
     ByVal HostLen As Long) As Long
 Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname As String) As Long
 Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, _
     ByVal hpvSource As Long, _
     ByVal cbCopy As Long)

 Private Function IPString2Long(ByVal ip As String) As Long
     For Each Item In Split(ip, ".")
         v = Hex(Item)
         If Len(v) =  Then v = "" & v
         hex_ = v & hex_
     Next
     IPString2Long = CLng("&H" & hex_)
 End Function

 Private Function GetIpAddressByHostName(ByVal hostname As String) As String
     Dim lpwsadata As WSADATA
     Call WSAStartup(WS_VERSION_REQD, lpwsadata)

     Dim hostent_addr As Long
     Dim host As HOSTENT
     Dim hostip_addr As Long
     Dim temp_ip_addr() As Byte
     Dim i As Integer
     Dim ip_address As String
     hostent_addr = gethostbyname(hostname)
     If hostent_addr =  Then
         Exit Function
     End If
     Call RtlMoveMemory(host, hostent_addr, LenB(host))
     Call RtlMoveMemory(hostip_addr, host.hAddrList, &)
     Do
         ReDim temp_ip_address( To host.hLength) As Byte
         Call RtlMoveMemory(temp_ip_address(), hostip_addr, host.hLength)

         For i =  To host.hLength
                ip_address = ip_address & temp_ip_address(i) & "."
         Next
         ip_address = Mid$(ip_address, , Len(ip_address) - )

         GetIpAddressByHostName = ip_address
         GoTo EXIT__
         '某些域名下可能有多个地址，但是这里获取首个地址就够了
         Debug.Print ip_address

         ip_address = ""
         host.hAddrList = host.hAddrList + LenB(host.hAddrList)
         Call RtlMoveMemory(hostip_addr, host.hAddrList, &)
     Loop While (hostip_addr <> )

 EXIT__:
     Erase temp_ip_address
     Call WSACleanup
 End Function

 Private Function Ping(ByVal ip As String, ReplyBuff As ICMP_ECHO_REPLY) As Long
     Dim IcmpHandle As Long

     IcmpHandle = IcmpCreateFile()
     If IcmpHandle Then
         Dim addr As Long
         Dim sendbuff As String
         Dim timeout As Long

         timeout =  'set the timeout 1000ms
         sendbuff = String(, &HFF)
         addr = IPString2Long(ip)
         Call RtlZeroMemory(ByVal VarPtr(ReplyBuff), Len(ReplyBuff))
         Call IcmpSendEcho(IcmpHandle, addr, sendbuff, Len(sendbuff), &, ReplyBuff, Len(ReplyBuff), timeout)
         Call IcmpCloseHandle(IcmpHandle)
         Ping = ReplyBuff.Status
     Else
         'icmp initailize fail
         Ping = -
     End If
 End Function

 Private Sub Command1_Click()
     Dim ip As String
     Dim ier As ICMP_ECHO_REPLY
     ip = GetIpAddressByHostName("www.baidu.com")
     Call Ping(ip, ier)
     Debug.Print "Reply from " & ip & ": bytes=" & ier.DataSize & " times=" & ier.RoundTripTime & " ttl=" & ier.Options.Ttl
 End Sub

　　

Reply from 61.135.169.105: bytes= times= ttl=
Reply from 61.135.169.105: bytes= times= ttl=
Reply from 61.135.169.105: bytes= times= ttl=