代码备忘
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