/ Snippet Library - View Code

Visual Basic / Internet and Web / Ping Computer

Snippet details

ID: 368

Viewed: 1307

Added: 2002-08-19

Version:

Snippets in this catagory
Show Printable Version

Pings Computer

General Details

Snippet uploaded by: snippet

Email : webmaster@snippetlibrary.com

Snippet By: Unknown

Snippet By:	Unknown
Declarations
Highlight Allnone
Code
Highlight All' Another sample found on the net somewhere.... ' '// '// Structures '// 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 Integer Reserved As Integer DataPointer As Long Options As ICMP_OPTIONS Data As String * 250 End Type Private Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLen As Integer hAddrList As Long End Type Private Const MAX_WSADescription = 256 Private Const MAX_WSASYSStatus = 128 Private Type WSADATA wVersion As Integer wHighVersion As Integer szDescription(0 To MAX_WSADescription) As Byte szSystemStatus(0 To MAX_WSASYSStatus) As Byte wMaxSockets As Integer wMaxUDPDG As Integer dwVendorInfo As Long End Type '// '// Win32s '// 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 Integer, ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Long Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, dwHostLen As Long) As Long Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) '// '// Constants '// Private Const IP_STATUS_BASE = 11000 Private Const IP_SUCCESS = 0 Private Const IP_BUF_TOO_SMALL = (11000 + 1) Private Const IP_DEST_NET_UNREACHABLE = (11000 + 2) Private Const IP_DEST_HOST_UNREACHABLE = (11000 + 3) Private Const IP_DEST_PROT_UNREACHABLE = (11000 + 4) Private Const IP_DEST_PORT_UNREACHABLE = (11000 + 5) Private Const IP_NO_RESOURCES = (11000 + 6) Private Const IP_BAD_OPTION = (11000 + 7) Private Const IP_HW_ERROR = (11000 + 8) Private Const IP_PACKET_TOO_BIG = (11000 + 9) Private Const IP_REQ_TIMED_OUT = (11000 + 10) Private Const IP_BAD_REQ = (11000 + 11) Private Const IP_BAD_ROUTE = (11000 + 12) Private Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13) Private Const IP_TTL_EXPIRED_REASSEM = (11000 + 14) Private Const IP_PARAM_PROBLEM = (11000 + 15) Private Const IP_SOURCE_QUENCH = (11000 + 16) Private Const IP_OPTION_TOO_BIG = (11000 + 17) Private Const IP_BAD_DESTINATION = (11000 + 18) Private Const IP_ADDR_DELETED = (11000 + 19) Private Const IP_SPEC_MTU_CHANGE = (11000 + 20) Private Const IP_MTU_CHANGE = (11000 + 21) Private Const IP_UNLOAD = (11000 + 22) Private Const IP_ADDR_ADDED = (11000 + 23) Private Const IP_GENERAL_FAILURE = (11000 + 50) Private Const MAX_IP_STATUS = 11000 + 50 Private Const IP_PENDING = (11000 + 255) Private Const PING_TIMEOUT = 200 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 Public Function GetIPAddress() As String Dim szHost As String * 256 Dim lpHost As Long Dim HOST As HOSTENT Dim dwIPAddr As Long Dim tmpIPAddr() As Byte Dim i As Integer Dim szIPAddr As String If Not SocketsInitialize() Then GetIPAddress = "" Exit Function End If If gethostname(szHost, 256) = SOCKET_ERROR Then GetIPAddress = "" MsgBox "Windows Sockets error " & Str(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name.", vbExclamation SocketsCleanup Exit Function End If szHost = Trim$(szHost) lpHost = gethostbyname(szHost) If lpHost = 0 Then GetIPAddress = "" MsgBox "Windows Sockets are not responding. Unable to successfully get Host Name.", vbExclamation SocketsCleanup Exit Function End If RtlMoveMemory HOST, lpHost, Len(HOST) RtlMoveMemory dwIPAddr, HOST.hAddrList, 4 ReDim tmpIPAddr(1 To HOST.hLen) RtlMoveMemory tmpIPAddr(1), dwIPAddr, HOST.hLen For i = 1 To HOST.hLen szIPAddr = szIPAddr & tmpIPAddr(i) & "." Next GetIPAddress = Mid$(szIPAddr, 1, Len(szIPAddr) - 1) SocketsCleanup End Function Public Function GetIPHostName() As String Dim szHost As String * 256 If Not SocketsInitialize() Then GetIPHostName = "" Exit Function End If If gethostname(szHost, 256) = SOCKET_ERROR Then GetIPHostName = "" MsgBox "Windows Sockets error " & Str(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name.", vbExclamation SocketsCleanup Exit Function End If '// GetIPHostName = Trim$(szHost) GetIPHostName = Left$(szHost, InStr(szHost, Chr(0)) - 1) SocketsCleanup End Function Private Function HiByte(ByVal wParam As Integer) HiByte = wParam &H100 And &HFF& End Function Private Function LoByte(ByVal wParam As Integer) LoByte = wParam And &HFF& End Function Public Function Ping(szAddress As String) As Long Dim hPort As Long, dwAddress As Long, szMessage As String Dim x As Long Dim ECHO As ICMP_ECHO_REPLY szMessage = "Echo This." dwAddress = AddressStringToLong(szAddress) hPort = IcmpCreateFile() x = IcmpSendEcho(hPort, dwAddress, szMessage, Len(szMessage), 0, ECHO, Len(ECHO), PING_TIMEOUT) If x = 0 Then Ping = ECHO.status * -1 Else ' 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 Ping = ECHO.RoundTripTime End If x = IcmpCloseHandle(hPort) End Function Function AddressStringToLong(szAddress As String) As Long Dim szTmp As String, i As Integer, Octets(1 To 4) As String szTmp = szAddress i = 0 While InStr(szTmp, ".") > 0 i = i + 1 Octets(i) = Mid(szTmp, 1, InStr(szTmp, ".") - 1) szTmp = Mid(szTmp, InStr(szTmp, ".") + 1) Wend i = i + 1 Octets(i) = szTmp If i <> 4 Then AddressStringToLong = 0 Exit Function End If AddressStringToLong = Val("&H" & Right("00" & Hex(Octets(4)), 2) & Right("00" & Hex(Octets(3)), 2) & Right("00" & Hex(Octets(2)), 2) & Right("00" & Hex(Octets(1)), 2)) End Function Public Function SocketsCleanup() As Boolean Dim x As Long x = WSACleanup() If x <> 0 Then MsgBox "Windows Sockets error " & Trim$(Str$(x)) & " occurred in Cleanup.", vbExclamation SocketsCleanup = False Else SocketsCleanup = True End If End Function Public Function SocketsInitialize() As Boolean Dim WSAD As WSADATA Dim x As Integer Dim szLoByte As String, szHiByte As String, szBuf As String x = WSAStartup(WS_VERSION_REQD, WSAD) If x <> 0 Then MsgBox "Windows Sockets for 32 bit Windows environments is not successfully responding.", vbExclamation SocketsInitialize = False Exit Function End If If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then szHiByte = Trim$(Str$(HiByte(WSAD.wVersion))) szLoByte = Trim$(Str$(LoByte(WSAD.wVersion))) szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte szBuf = szBuf & " is not supported by Windows Sockets for 32 bit Windows environments." MsgBox szBuf, vbExclamation SocketsInitialize = False Exit Function End If If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then szBuf = "This application requires a minimum of " & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets." MsgBox szBuf, vbExclamation SocketsInitialize = False Exit Function End If SocketsInitialize = True End Function Public Function DetermineIP(szTmp As String) As Boolean On Error GoTo Handler Dim i As Integer Dim nOctet As Integer While InStr(szTmp, ".") > 0 i = i + 1 nOctet = Mid(szTmp, 1, InStr(szTmp, ".") - 1) szTmp = Mid(szTmp, InStr(szTmp, ".") + 1) Wend If (i <> 3) Then DetermineIP = False Else DetermineIP = True End If Exit Function Handler: DetermineIP = False End Function

No Reviews to show