'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 * 250
End Type
Private Const REQUEST_TIMEOUT = 11010
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 = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
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(0 To WSADescription_Len) As Byte
szSystemStatus(0 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) = 1 Then v = "0" & 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 = 0 Then
Exit Function
End If
Call RtlMoveMemory(host, hostent_addr, LenB(host))
Call RtlMoveMemory(hostip_addr, host.hAddrList, 4&)
Do
ReDim temp_ip_address(1 To host.hLength) As Byte
Call RtlMoveMemory(temp_ip_address(1), hostip_addr, host.hLength)
For i = 1 To host.hLength
ip_address = ip_address & temp_ip_address(i) & "."
Next
ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
GetIpAddressByHostName = ip_address
GoTo EXIT__
Debug.Print ip_address
ip_address = ""
host.hAddrList = host.hAddrList + LenB(host.hAddrList)
Call RtlMoveMemory(hostip_addr, host.hAddrList, 4&)
Loop While (hostip_addr <> 0)
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 = 1000 'set the timeout 1000ms
sendbuff = String(32, &HFF)
addr = IPString2Long(ip)
Call RtlZeroMemory(ByVal VarPtr(ReplyBuff), Len(ReplyBuff))
Call IcmpSendEcho(IcmpHandle, addr, sendbuff, Len(sendbuff), 0&, ReplyBuff, Len(ReplyBuff), timeout)
Call IcmpCloseHandle(IcmpHandle)
Ping = ReplyBuff.Status
Else
'icmp initailize fail
Ping = -1
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
Private Sub Command2_Click()
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
Dim ip As String
Dim ier As ICMP_ECHO_REPLY
For i = 0 To List1.ListCount - 1
ip = List1.List(i)
Call Ping(ip, ier)
Debug.Print "Reply from " & ip & ": bytes=" & ier.DataSize & " times=" & ier.RoundTripTime & " ttl=" & ier.Options.Ttl
Next
End Sub
這是實作Ping功能代碼！我想封裝成Dll！不知如何封裝！
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/277546.html
標籤：VB基礎類