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=

VB6之ICMP实现ping功能的相关教程结束。