Private Function DoPing(szAddress As String, sDataToSend As String, ECHO As ICMP_ECHO_REPLY, Optional TimeOut As Long = PING_TIMEOUT) As Long
Dim hPort As Long, dwAddress As Long, iOpt As Long
dwAddress = AddressStringToLong(szAddress)
hPort = IcmpCreateFile()
If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, _
ECHO, Len(ECHO), TimeOut) Then
'the ping succeeded,
'.Status will be 0
'.RoundTripTime is the 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
DoPing = IP_SUCCESS
Else
If ECHO.Status = 0 Then
DoPing = -1
Else
DoPing = ECHO.Status * -1
End If
End If
Call IcmpCloseHandle(hPort)
End Function
Private Function AddressStringToLong(ByVal tmp As String) As Long
Dim i As Integer, parts(1 To 4) As String
i = 0
'we have to extract each part of the
'123.456.789.123 string, delimited by
'a period
While InStr(tmp, ".") > 0
i = i + 1
parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)
tmp = Mid(tmp, InStr(tmp, ".") + 1)
Wend
i = i + 1
parts(i) = tmp
If i <> 4 Then
AddressStringToLong = 0
Exit Function
End If
'build the long value out of the
'hex of the extracted strings
AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
Right("00" & Hex(parts(3)), 2) & _
Right("00" & Hex(parts(2)), 2) & _
Right("00" & Hex(parts(1)), 2))
End Function
Public Function GetStatusCode(Status As IP_STATUS) As String
Dim msg As String
Select Case Status
Case IP_SUCCESS: msg = "IP Success"
Case IP_BUF_TOO_SMALL: msg = "IP Buffer too small"
Case IP_DEST_NET_UNREACHABLE: msg = "IP Destination Net Unreachable"
Case IP_DEST_HOST_UNREACHABLE: msg = "IP Destination Host Unreachable"
Case IP_DEST_PROT_UNREACHABLE: msg = "IP Destination Protocol Unreachable"
Case IP_DEST_PORT_UNREACHABLE: msg = "IP Destination Port Unreachable"
Case IP_NO_RESOURCES: msg = "IP No Resources"
Case IP_BAD_OPTION: msg = "IP Bad Option"
Case IP_HW_ERROR: msg = "IP Hardware Error"
Case IP_PACKET_TOO_BIG: msg = "IP Packet too big"
Case IP_REQ_TIMED_OUT: msg = "IP Reqquest timed out"
Case IP_BAD_REQ: msg = "IP Bad Request"
Case IP_BAD_ROUTE: msg = "IP Bad Route"
Case IP_TTL_EXPIRED_TRANSIT: msg = "IP TTL Expired Transit"
Case IP_TTL_EXPIRED_REASSEM: msg = "IP TTL Expired Reassem"
Case IP_PARAM_PROBLEM: msg = "IP Parameter Problem"
Case IP_SOURCE_QUENCH: msg = "IP Source Quench"
Case IP_OPTION_TOO_BIG: msg = "IP Option too big"
Case IP_BAD_DESTINATION: msg = "IP Bad Destination"
Case IP_ADDR_DELETED: msg = "IP Address Deleted"
Case IP_SPEC_MTU_CHANGE: msg = "IP Spec MTU Change"
Case IP_MTU_CHANGE: msg = "IP MTU Change"
Case IP_UNLOAD: msg = "IP Unload"
Case IP_ADDR_ADDED: msg = "IP Address Added"
Case IP_GENERAL_FAILURE: msg = "IP General Failure"
Case IP_PENDING: msg = "IP Pending"
Case PING_TIMEOUT: msg = "Ping timeout"
Case -1: msg = "Destination host unreachable."
Case Else: msg = "Unknown message returned"
End Select
Debug.Print Status
GetStatusCode = msg
End Function
Public Function GetIPAddress(Optional sHost As String, _
Optional serrmsg As String) As String
'Resolves the host-name (or current machine if balnk) to an IP address
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
Dim werr As Long
If Not SocketsInitialize() Then
GetIPAddress = ""
Exit Function
End If
If sHost = "" Then
If gethostname(sHostName, 256) = SOCKET_ERROR Then
werr = WSAGetLastError()
GetIPAddress = ""
serrmsg = "Windows Sockets error " & Str$(werr) & _
" has occurred. Unable to successfully get Host Name." & vbCrLf
GetIPAddress = ""
SocketsCleanup
Exit Function
End If
sHostName = Trim$(sHostName)
Else
sHostName = Trim$(sHost) & Chr$(0)
End If
lpHost = gethostbyname(sHostName)
If lpHost = 0 Then
werr = WSAGetLastError()
GetIPAddress = ""
serrmsg = "Windows Sockets error " & Str$(werr) & _
" has occurred. Unable to successfully get Host Name." & vbCrLf
GetIPAddress = ""
SocketsCleanup
Exit Function
End If
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
ReDim tmpIPAddr(1 To HOST.hLen)
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
For i = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
SocketsCleanup
End Function
Public Function GetIPHostName() As String
'Returns the current machine's name
Dim sHostName As String * 256
If Not SocketsInitialize() Then
GetIPHostName = ""
Exit Function
End If
If gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPHostName = ""
MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
" has occurred. Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
SocketsCleanup
End Function
Public Function Ping(Address As String, RoundTripTime As String, DataMatch As Boolean, Optional DataSize As Long = 32, Optional TimeOut As Long = PING_TIMEOUT) As Long
Dim ECHO As ICMP_ECHO_REPLY, pos As Integer, Dt As String, sAddress As String
On Error GoTo DPErr
If AddressStringToLong(Address) = 0 Then
sAddress = GetIPAddress(Address)
Else
sAddress = Address
End If
If SocketsInitialize() Then
If DataSize <= 0 Then DataSize = 10
For pos = 1 To DataSize
Dt = Dt & Chr$(Rnd() * 254 + 1)
Next pos
'ping an ip address, passing the
'address and the ECHO structure
Ping = DoPing(sAddress, Dt, ECHO, TimeOut)
'display the results from the ECHO structure
RoundTripTime = ECHO.RoundTripTime & " ms"
'DataSize = ECHO.DataSize & " bytes"
If Left$(ECHO.Data, 1) <> Chr$(0) Then
pos = InStr(ECHO.Data, Chr$(0))
DataMatch = (Left$(ECHO.Data, pos - 1) = Dt)
End If
SocketsCleanup
Else
Ping = IP_GENERAL_FAILURE
End If
Exit Function
DPErr:
Ping = IP_GENERAL_FAILURE
End Function
Private Function PointerToString(lpString As Long) As String
' The PointerToString function is used to convert a
' pointer to a string into a string variable:
Dim Buffer() As Byte
Dim nLen As Long
If lpString Then
nLen = lstrlen(lpString)
If nLen Then
ReDim Buffer(0 To (nLen - 1)) As Byte
CopyMemory Buffer(0), ByVal lpString, nLen
PointerToString = StrConv(Buffer, vbUnicode)
End If
End If
End Function
Public Function GetHostFromIP(sIPAddr As String, Optional serrmsg As String) As String
' Finally, the GetHostFromIP function returns the host name
' from an IP address string:
'Resolves the IP address to a host name
Dim dwIPAddr As Long
Dim lpHost As Long
Dim HOST As HOSTENT
Dim werr As Long
If Not SocketsInitialize() Then
GetHostFromIP = ""
Exit Function
End If
dwIPAddr = inet_addr(sIPAddr)
lpHost = gethostbyaddr(dwIPAddr, Len(dwIPAddr), 2)
If lpHost = 0 Then
werr = WSAGetLastError()
serrmsg = "Windows Sockets error " & Str$(werr) & _
" has occurred. Unable to successfully get Host Name." & vbCrLf
GetHostFromIP = ""
SocketsCleanup
Exit Function
End If
CopyMemory HOST, lpHost, Len(HOST)
GetHostFromIP = PointerToString(HOST.hName)
SocketsCleanup
End Function
Finding The ISP [RESOLVED]
Reply With Quote
