Private Const PING_TIMEOUT As Long = 2000 'Wait 2 secs
Private Type ICMP_OPTIONS
ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Private Type ICMP_ECHO_REPLY
Address As Long
Status As Long
RoundTripTime As Long
datasize As Long
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type
Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Public Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (lpEventAttributes As SECURITY_ATTRIBUTES, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long
Public Declare Function WaitForMultipleObjects Lib "kernel32" (ByVal nCount As Long, lpHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long) As Long
Public Declare Function ResetEvent Lib "kernel32" (ByVal hEvent As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) 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 Declare Function IcmpSendEcho2 Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal hEvent As Long, ByVal ApcRoutine As Any, _
ByVal ApcContext 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 Declare Function inet_addr Lib "wsock32.dll" (ByVal s As String) As Long
Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal addr As Long) As Long
Sub test1()
Const sSendData As String = "TESTMESSAGE"
Dim buffer As ICMP_ECHO_REPLY
Dim lhwndPort As Long
lhwndPort = IcmpCreateFile
Cells(1, 1) = "Pinging 10.10.11.1 using IcmpSendEcho"
If IcmpSendEcho(lhwndPort, inet_addr("10.10.11.1"), sSendData, Len(sSendData), _
0, buffer, Len(buffer), PING_TIMEOUT) <> 0 Then
Cells(1, 2) = buffer.Address
Else
Cells(1, 2) = "Failed"
End If
End Sub
Sub test2()
Const sSendData As String = "TESTMESSAGE"
Dim buffer As ICMP_ECHO_REPLY
Dim lhwndPort As Long
Dim hEvent As Long
Dim sd As SECURITY_ATTRIBUTES
With sd
.nLength = Len(sd) 'we pass the length of sd
.lpSecurityDescriptor = 0
.bInheritHandle = 0
End With
hEvent = CreateEvent(sd, True, False, "PING2")
lhwndPort = IcmpCreateFile
Cells(2, 1) = "Pinging 10.10.11.1 using IcmpSendEcho2"
Call IcmpSendEcho2(lhwndPort, hEvent, 0&, 0, inet_addr("10.10.11.1"), sSendData, Len(sSendData), _
0, buffer, Len(buffer), PING_TIMEOUT)
If WaitForMultipleObjects(1, hEvent, True, 10000) = 0 Then
Cells(2, 2) = buffer.Address
Else
Cells(2, 2) = "Failed"
End If
End Sub