VB6之ICMP实现ping功能

代码备忘

 

  1 'code by lichmama from cnblogs.com
  2 Private Type IPAddr
  3     ip1 As Byte
  4     ip2 As Byte
  5     ip3 As Byte
  6     ip4 As Byte
  7 End Type
  8  
  9 Private Type IP_OPTION_INFORMATION
 10     Ttl As Byte
 11     Tos As Byte
 12     Flags As Byte
 13     OptionsSize As Byte
 14     OptionsData As Long
 15 End Type
 16  
 17 Private Type ICMP_ECHO_REPLY
 18     Address As IPAddr
 19     Status As Long
 20     RoundTripTime As Long
 21     DataSize As Integer
 22     Reserved As Integer
 23     ptrData As Long
 24     Options As IP_OPTION_INFORMATION
 25     Data As String * 250
 26 End Type
 27  
 28 Private Const REQUEST_TIMEOUT = 11010
 29  
 30 Private Declare Sub RtlZeroMemory Lib "KERNEL32" (dest As Any, ByVal numBytes As Long)
 31 Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
 32 Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
 33 Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, _
 34     ByVal DestinationAddress As Long, _
 35     ByVal RequestData As String, _
 36     ByVal RequestSize As Long, _
 37     ByVal RequestOptions As Long, _
 38     ReplyBuffer As ICMP_ECHO_REPLY, _
 39     ByVal ReplySize As Long, _
 40     ByVal timeout As Long) As Long
 41 
 42 Private Const WS_VERSION_REQD = &H101
 43 Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
 44 Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
 45 Private Const MIN_SOCKETS_REQD = 1
 46 Private Const SOCKET_ERROR = -1
 47 Private Const WSADescription_Len = 256
 48 Private Const WSASYS_Status_Len = 128
 49 
 50 Private Type HOSTENT
 51     hName As Long
 52     hAliases As Long
 53     hAddrType As Integer
 54     hLength As Integer
 55     hAddrList As Long
 56 End Type
 57 
 58 Private Type WSADATA
 59     wversion As Integer
 60     wHighVersion As Integer
 61     szDescription(0 To WSADescription_Len) As Byte
 62     szSystemStatus(0 To WSASYS_Status_Len) As Byte
 63     iMaxSockets As Integer
 64     iMaxUdpDg As Integer
 65     lpszVendorInfo As Long
 66 End Type
 67 
 68 Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
 69 Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Integer, _
 70     lpwsadata As WSADATA) As Long
 71 Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
 72 Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal hostname As String, _
 73     ByVal HostLen As Long) As Long
 74 Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname As String) As Long
 75 Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, _
 76     ByVal hpvSource As Long, _
 77     ByVal cbCopy As Long)
 78 
 79 Private Function IPString2Long(ByVal ip As String) As Long
 80     For Each Item In Split(ip, ".")
 81         v = Hex(Item)
 82         If Len(v) = 1 Then v = "0" & v
 83         hex_ = v & hex_
 84     Next
 85     IPString2Long = CLng("&H" & hex_)
 86 End Function
 87 
 88 Private Function GetIpAddressByHostName(ByVal hostname As String) As String
 89     Dim lpwsadata As WSADATA
 90     Call WSAStartup(WS_VERSION_REQD, lpwsadata)
 91     
 92     Dim hostent_addr As Long
 93     Dim host As HOSTENT
 94     Dim hostip_addr As Long
 95     Dim temp_ip_addr() As Byte
 96     Dim i As Integer
 97     Dim ip_address As String
 98     hostent_addr = gethostbyname(hostname)
 99     If hostent_addr = 0 Then
100         Exit Function
101     End If
102     Call RtlMoveMemory(host, hostent_addr, LenB(host))
103     Call RtlMoveMemory(hostip_addr, host.hAddrList, 4&)
104     Do
105         ReDim temp_ip_address(1 To host.hLength) As Byte
106         Call RtlMoveMemory(temp_ip_address(1), hostip_addr, host.hLength)
107 
108         For i = 1 To host.hLength
109                ip_address = ip_address & temp_ip_address(i) & "."
110         Next
111         ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
112         
113         GetIpAddressByHostName = ip_address
114         GoTo EXIT__
115         '某些域名下可能有多个地址，但是这里获取首个地址就够了
116         Debug.Print ip_address
117 
118         ip_address = ""
119         host.hAddrList = host.hAddrList + LenB(host.hAddrList)
120         Call RtlMoveMemory(hostip_addr, host.hAddrList, 4&)
121     Loop While (hostip_addr <> 0)
122 
123 EXIT__:
124     Erase temp_ip_address
125     Call WSACleanup
126 End Function
127 
128 Private Function Ping(ByVal ip As String, ReplyBuff As ICMP_ECHO_REPLY) As Long
129     Dim IcmpHandle As Long
130      
131     IcmpHandle = IcmpCreateFile()
132     If IcmpHandle Then
133         Dim addr As Long
134         Dim sendbuff As String
135         Dim timeout As Long
136          
137         timeout = 1000 'set the timeout 1000ms
138         sendbuff = String(32, &HFF)
139         addr = IPString2Long(ip)
140         Call RtlZeroMemory(ByVal VarPtr(ReplyBuff), Len(ReplyBuff))
141         Call IcmpSendEcho(IcmpHandle, addr, sendbuff, Len(sendbuff), 0&, ReplyBuff, Len(ReplyBuff), timeout)
142         Call IcmpCloseHandle(IcmpHandle)
143         Ping = ReplyBuff.Status
144     Else
145         'icmp initailize fail
146         Ping = -1
147     End If
148 End Function
149  
150 Private Sub Command1_Click()
151     Dim ip As String
152     Dim ier As ICMP_ECHO_REPLY
153     ip = GetIpAddressByHostName("www.baidu.com")
154     Call Ping(ip, ier)
155     Debug.Print "Reply from " & ip & ": bytes=" & ier.DataSize & " times=" & ier.RoundTripTime & " ttl=" & ier.Options.Ttl
156 End Sub

　　

Reply from 61.135.169.105: bytes=32 times=31 ttl=55
Reply from 61.135.169.105: bytes=32 times=29 ttl=55
Reply from 61.135.169.105: bytes=32 times=28 ttl=55

 

posted @ 2014-07-05 23:22  lichmama  阅读(1267)  评论(0)  编辑  收藏  举报