Option Explicit
Public Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long
Public Const IP_SUCCESS As Long = 0
Public Const MAX_IP_STATUS As Long = (11000 + 50)
Public Const IP_PENDING As Long = (11000 + 255)
Public Const PING_TIMEOUT As Long = 500
Public Const WS_VERSION_REQD As Long = &H101
Public Const MIN_SOCKETS_REQD As Long = 1
Public Const SOCKET_ERROR As Long = -1
Public Const INADDR_NONE As Long = &HFFFFFFFF
Public Const MAX_WSADescription As Long = 256
Public Const MAX_WSASYSStatus As Long = 128
Public Type ICMP_OPTIONS
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Public Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Long 'formerly integer
'Reserved As Integer
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type
Public Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type
Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Public Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal IcmpHandle As Long) As Long
Public 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
Public Declare Function WSAGetLastError Lib "wsock32" () As Long
Public Declare Function WSAStartup Lib "wsock32" _
(ByVal wVersionRequired As Long, _
lpWSADATA As WSADATA) As Long
Public Declare Function WSACleanup Lib "wsock32" () As Long
Public Declare Function gethostname Lib "wsock32" _
(ByVal szHost As String, _
ByVal dwHostLen As Long) As Long
Public Declare Function gethostbyname Lib "wsock32" _
(ByVal szHost As String) As Long
Public Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(xDest As Any, _
xSource As Any, _
ByVal nbytes As Long)
Public Declare Function inet_addr Lib "wsock32" _
(ByVal s As String) As Long
Public Function Ping(sAddress As String, _
sDataToSend As String, _
ECHO As ICMP_ECHO_REPLY) As String
'If Ping succeeds :
'.RoundTripTime = time in ms for the ping to complete,
'.Data is the data returned (NULL terminated)
'.Address is the Ip address that actually replied
'.DataSize is the size of the string in .Data
'.Status will be 0
'
'If Ping fails .Status will be the error code
Dim hPort As Long
Dim dwAddress As Long
'convert the address into a long representation
dwAddress = inet_addr(sAddress)
'if a valid address..
If dwAddress <> INADDR_NONE Then
'open a port
hPort = IcmpCreateFile()
'and if successful,
If hPort Then
'ping it.
Call IcmpSendEcho(hPort, _
dwAddress, _
sDataToSend, _
Len(sDataToSend), _
0, _
ECHO, _
Len(ECHO), _
PING_TIMEOUT)
'return the status as ping succes and close
Ping = ECHO.status & "#" & ECHO.RoundTripTime
Call IcmpCloseHandle(hPort)
End If
Else
'the address format was probably invalid
Ping = INADDR_NONE
End If
End Function
Public Sub SocketsCleanup()
If WSACleanup() <> 0 Then
MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation
End If
End Sub
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function
Public Function GetStatusCode(status As Long) As String
Dim MSG As String
Select Case status
Case IP_SUCCESS: MSG = "ip success"
Case Else: MSG = "unknown msg returned"
End Select
GetStatusCode = CStr(status) & " [ " & MSG & " ]"
End Function
Reply With Quote
