home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD137391132001.psc / basPing.bas next >
Encoding:
BASIC Source File  |  2001-01-13  |  15.7 KB  |  447 lines

  1. Attribute VB_Name = "basPing"
  2. '* Original author unknown
  3.  
  4. Option Explicit
  5.  
  6. Private Const IP_STATUS_BASE = 11000
  7. Private Const IP_SUCCESS = 0
  8. Private Const IP_BUF_TOO_SMALL = (11000 + 1)
  9. Private Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
  10. Private Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
  11. Private Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
  12. Private Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
  13. Private Const IP_NO_RESOURCES = (11000 + 6)
  14. Private Const IP_BAD_OPTION = (11000 + 7)
  15. Private Const IP_HW_ERROR = (11000 + 8)
  16. Private Const IP_PACKET_TOO_BIG = (11000 + 9)
  17. Private Const IP_REQ_TIMED_OUT = (11000 + 10)
  18. Private Const IP_BAD_REQ = (11000 + 11)
  19. Private Const IP_BAD_ROUTE = (11000 + 12)
  20. Private Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
  21. Private Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
  22. Private Const IP_PARAM_PROBLEM = (11000 + 15)
  23. Private Const IP_SOURCE_QUENCH = (11000 + 16)
  24. Private Const IP_OPTION_TOO_BIG = (11000 + 17)
  25. Private Const IP_BAD_DESTINATION = (11000 + 18)
  26. Private Const IP_ADDR_DELETED = (11000 + 19)
  27. Private Const IP_SPEC_MTU_CHANGE = (11000 + 20)
  28. Private Const IP_MTU_CHANGE = (11000 + 21)
  29. Private Const IP_UNLOAD = (11000 + 22)
  30. Private Const IP_ADDR_ADDED = (11000 + 23)
  31. Private Const IP_GENERAL_FAILURE = (11000 + 50)
  32. Private Const MAX_IP_STATUS = 11000 + 50
  33. Private Const IP_PENDING = (11000 + 255)
  34. Private Const PING_TIMEOUT = 200
  35. Private Const WS_VERSION_REQD = &H101
  36. Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
  37. Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
  38. Private Const MIN_SOCKETS_REQD = 1
  39. Private Const SOCKET_ERROR = -1
  40.  
  41. Private Const AF_UNSPEC As Integer = 0                    ' unspecified
  42. Private Const AF_UNIX As Integer = 1                      ' local to host (pipes, portals)
  43. Private Const AF_INET As Integer = 2                     ' internetwork: UDP, TCP, etc.
  44. Private Const AF_IMPLINK As Integer = 3                  ' arpanet imp addresses
  45. Private Const AF_PUP As Integer = 4                      ' pup protocols: e.g. BSP
  46. Private Const AF_CHAOS As Integer = 5                    ' mit CHAOS protocols
  47. Private Const AF_IPX As Integer = 6                      ' IPX and SPX
  48. Private Const AF_NS As Integer = AF_IPX                  ' XEROX NS protocols
  49. Private Const AF_ISO As Integer = 7                      ' ISO protocols
  50. Private Const AF_OSI As Integer = AF_ISO                 ' OSI is ISO
  51. Private Const AF_ECMA As Integer = 8                     ' european computer manufacturers
  52. Private Const AF_DATAKIT As Integer = 9                  ' datakit protocols
  53. Private Const AF_CCITT As Integer = 10                    ' CCITT protocols, X.25 etc
  54. Private Const AF_SNA As Integer = 11                      ' IBM SNA
  55. Private Const AF_DECnet As Integer = 12                   ' DECnet
  56. Private Const AF_DLI As Integer = 13                      ' Direct data link interface
  57. Private Const AF_LAT As Integer = 14                      ' LAT
  58. Private Const AF_HYLINK As Integer = 15                  ' NSC Hyperchannel
  59. Private Const AF_APPLETALK As Integer = 16               ' AppleTalk
  60. Private Const AF_NETBIOS As Integer = 17                  ' NetBios-style addresses
  61. Private Const AF_VOICEVIEW As Integer = 18               ' VoiceView
  62. Private Const AF_FIREFOX As Integer = 19                  ' Protocols from Firefox
  63. Private Const AF_UNKNOWN1 As Integer = 20                 ' Somebody is using this!
  64. Private Const AF_BAN As Integer = 21                     ' Banyan
  65. Private Const AF_ATM As Integer = 22                     ' Native ATM Services
  66. Private Const AF_INET6 As Integer = 23                   ' Internetwork Version 6
  67. Private Const AF_CLUSTER As Integer = 24                 ' Microsoft Wolfpack
  68. Private Const AF_12844 As Integer = 25                   ' IEEE 1284.4 WG AF
  69.  
  70. Private Const MAX_WSADescription = 256
  71. Private Const MAX_WSASYSStatus = 128
  72.  
  73. Private Type Inet_address
  74.   Byte4 As Byte
  75.   Byte3 As Byte
  76.   Byte2 As Byte
  77.   Byte1 As Byte
  78. End Type
  79. Private IPLong As Inet_address
  80.  
  81.  
  82. Private Type ICMP_OPTIONS
  83.     TTL             As Byte
  84.     Tos             As Byte
  85.     flags           As Byte
  86.     OptionsSize     As Byte
  87.     OptionsData     As Long
  88. End Type
  89.  
  90. Dim ICMPOPT As ICMP_OPTIONS
  91.  
  92. Private Type ICMP_ECHO_REPLY
  93.     Address         As Long
  94.     Status          As Long
  95.     RoundTripTime   As Long
  96.     DataSize        As Long  'formerly integer
  97.   '  Reserved        As Integer
  98.     DataPointer     As Long
  99.     Options         As ICMP_OPTIONS
  100.     data            As String * 250
  101. End Type
  102.  
  103. Private Type Hostent
  104.     hName As Long
  105.     hAliases As Long
  106.     hAddrType As Integer
  107.     hLength As Integer
  108.     hAddrList As Long
  109. End Type
  110.  
  111. Private Type WSAdata
  112.     wVersion As Integer
  113.     wHighVersion As Integer
  114.     szDescription(0 To MAX_WSADescription) As Byte
  115.     szSystemStatus(0 To MAX_WSASYSStatus) As Byte
  116.     wMaxSockets As Long
  117.     wMaxUDPDG As Long
  118.     dwVendorInfo As Long
  119. End Type
  120.  
  121. Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
  122. Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
  123. 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
  124. Private Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
  125. Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired As Long, lpWSAData As WSAdata) As Long
  126. Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
  127. Private Declare Function gethostname Lib "wsock32.dll" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
  128. Private Declare Function gethostbyaddr Lib "wsock32.dll" (Addr As Long, addrLen As Long, addrType As Long) As Long
  129. Private Declare Function inet_addr Lib "wsock32.dll" (ByVal ipaddress$) As Long
  130. Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
  131.  
  132.  
  133.  
  134. 'Public pIPo As IP_OPTION_INFORMATION
  135.  
  136.  
  137.  
  138. 'Public pIPe As IP_ECHO_REPLY
  139.  
  140. 'Winsock
  141. Declare Function gethostbyname& Lib "wsock32.dll" (ByVal hostname$)
  142.  
  143. 'Kernel
  144. Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
  145.  
  146. Private Function GetStatusCode(Status As Long) As String
  147.  
  148.    Dim msg As String
  149.  
  150.    Select Case Status
  151.       Case IP_SUCCESS:               msg = "ip success"
  152.       Case IP_BUF_TOO_SMALL:         msg = "ip buf too_small"
  153.       Case IP_DEST_NET_UNREACHABLE:  msg = "ip dest net unreachable"
  154.       Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"
  155.       Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"
  156.       Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"
  157.       Case IP_NO_RESOURCES:          msg = "ip no resources"
  158.       Case IP_BAD_OPTION:            msg = "ip bad option"
  159.       Case IP_HW_ERROR:              msg = "ip hw_error"
  160.       Case IP_PACKET_TOO_BIG:        msg = "ip packet too_big"
  161.       Case IP_REQ_TIMED_OUT:         msg = "ip req timed out"
  162.       Case IP_BAD_REQ:               msg = "ip bad req"
  163.       Case IP_BAD_ROUTE:             msg = "ip bad route"
  164.       Case IP_TTL_EXPIRED_TRANSIT:   msg = "ip ttl expired transit"
  165.       Case IP_TTL_EXPIRED_REASSEM:   msg = "ip ttl expired reassem"
  166.       Case IP_PARAM_PROBLEM:         msg = "ip param_problem"
  167.       Case IP_SOURCE_QUENCH:         msg = "ip source quench"
  168.       Case IP_OPTION_TOO_BIG:        msg = "ip option too_big"
  169.       Case IP_BAD_DESTINATION:       msg = "ip bad destination"
  170.       Case IP_ADDR_DELETED:          msg = "ip addr deleted"
  171.       Case IP_SPEC_MTU_CHANGE:       msg = "ip spec mtu change"
  172.       Case IP_MTU_CHANGE:            msg = "ip mtu_change"
  173.       Case IP_UNLOAD:                msg = "ip unload"
  174.       Case IP_ADDR_ADDED:            msg = "ip addr added"
  175.       Case IP_GENERAL_FAILURE:       msg = "ip general failure"
  176.       Case IP_PENDING:               msg = "ip pending"
  177.       Case PING_TIMEOUT:             msg = "ping timeout"
  178.       Case Else:                     msg = "unknown  msg returned"
  179.    End Select
  180.    
  181.    GetStatusCode = CStr(Status) & "   [ " & msg & " ]"
  182.    
  183. End Function
  184.  
  185.  
  186. Private Function HiByte(ByVal wParam As Long) As Integer
  187.  
  188.     HiByte = wParam \ &H100 And &HFF&
  189.  
  190. End Function
  191.  
  192.  
  193. Private Function LoByte(ByVal wParam As Long) As Integer
  194.  
  195.     LoByte = wParam And &HFF&
  196.  
  197. End Function
  198.  
  199.  
  200. Private Function PingAddress(szAddress As String, ECHO As ICMP_ECHO_REPLY, Optional TimeOut As Long = PING_TIMEOUT) As Long
  201.  
  202.    Dim hPort As Long
  203.    Dim dwAddress As Long
  204.    Dim sDataToSend As String
  205.    Dim iOpt As Long
  206.    
  207.    sDataToSend = "Echo This"
  208.    dwAddress = AddressStringToLong(szAddress)
  209.    
  210.    hPort = IcmpCreateFile()
  211.    
  212.    If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, ECHO, Len(ECHO), TimeOut) Then
  213.    
  214.         'the ping succeeded,
  215.         '.Status will be 0
  216.         '.RoundTripTime is the time in ms for
  217.         '               the ping to complete,
  218.         '.Data is the data returned (NULL terminated)
  219.         '.Address is the Ip address that actually replied
  220.         '.DataSize is the size of the string in .Data
  221.          PingAddress = ECHO.RoundTripTime
  222.    Else: PingAddress = ECHO.Status * -1
  223.    End If
  224.                        
  225.    Call IcmpCloseHandle(hPort)
  226.    
  227. End Function
  228.    
  229.  
  230. Private Function AddressStringToLong(ByVal tmp As String) As Long
  231.  
  232. Dim i As Integer
  233. Dim parts(1 To 4) As String
  234.    
  235.     i = 0
  236.     
  237.     If InStr(1, tmp, ".", vbTextCompare) = 0 Then
  238.         AddressStringToLong = gethostbyname(tmp)
  239.     Else
  240.         'we have to extract each part of the
  241.         '123.456.789.123 string, delimited by
  242.         'a period
  243.         While InStr(tmp, ".") > 0
  244.           i = i + 1
  245.           parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)
  246.           tmp = Mid(tmp, InStr(tmp, ".") + 1)
  247.         Wend
  248.         
  249.         i = i + 1
  250.         parts(i) = tmp
  251.         
  252.         If i <> 4 Then
  253.           AddressStringToLong = 0
  254.           Exit Function
  255.         End If
  256.         
  257.         'build the long value out of the
  258.         'hex of the extracted strings
  259.         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))
  260.    End If
  261. End Function
  262.  
  263.  
  264. Private Sub SocketsCleanup()
  265.  
  266.    Dim X As Long
  267.    
  268.   'need to use a var (insread of embedding
  269.   'in the If..Then call) becuse the function
  270.   'returns the error code if failed.
  271.    X = WSACleanup()
  272.  
  273.    If X <> 0 Then
  274.        MsgBox "Windows Sockets error " & Trim$(Str$(X)) & " occurred in Cleanup.", vbExclamation
  275.    End If
  276.     
  277. End Sub
  278.  
  279.  
  280. Private Function SocketsInitialize() As Boolean
  281.  
  282.     Dim WSAD As WSAdata
  283.     Dim X As Integer
  284.     Dim szLoByte As String
  285.     Dim szHiByte As String
  286.     Dim szBuf As String
  287.     
  288.     X = WSAStartup(WS_VERSION_REQD, WSAD)
  289.     
  290.    'check for valid response
  291.     If X <> 0 Then
  292.  
  293.         MsgBox "Windows Sockets for 32 bit Windows " & _
  294.                "environments is not successfully responding."
  295.         Exit Function
  296.  
  297.     End If
  298.     
  299.    'check that the version of sockets is supported
  300.     If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
  301.        (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
  302.         HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
  303.         
  304.         szHiByte = Trim$(Str$(HiByte(WSAD.wVersion)))
  305.         szLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))
  306.         szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte
  307.         szBuf = szBuf & " is not supported by Windows " & _
  308.                           "Sockets for 32 bit Windows environments."
  309.         MsgBox szBuf, vbExclamation
  310.         Exit Function
  311.         
  312.     End If
  313.     
  314.    'check that there are available sockets
  315.     If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
  316.  
  317.         szBuf = "This application requires a minimum of " & _
  318.                  Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
  319.         MsgBox szBuf, vbExclamation
  320.         Exit Function
  321.  
  322.     End If
  323.     
  324.     SocketsInitialize = True
  325.         
  326. End Function
  327.  
  328. Public Function Ping(ByVal hostnameOrIpaddress As String, Optional timeOutmSec As Long = PING_TIMEOUT) As Boolean
  329. Dim echoValues As ICMP_ECHO_REPLY
  330. Dim pos As Integer
  331. Dim Count As Integer
  332. Dim returnIp As Collection
  333.    
  334.     On Error GoTo e_Trap
  335.     If Trim(hostnameOrIpaddress) = "" Then
  336.         Ping = False
  337.         Exit Function
  338.     End If
  339.     
  340.     If SocketsInitialize() Then
  341.         
  342.         If InStr(1, hostnameOrIpaddress, ".", vbTextCompare) <> 0 Then
  343.             If IsNumeric(Mid(hostnameOrIpaddress, 1, InStr(1, hostnameOrIpaddress, ".") - 1)) = False Then
  344.                 Set returnIp = ResolveIpaddress(hostnameOrIpaddress)
  345.                 If returnIp.Count = 0 Then
  346.                     Ping = False
  347.                     Exit Function
  348.                 Else
  349.                     hostnameOrIpaddress = returnIp.Item(1)
  350.                 End If
  351.             End If
  352.         End If
  353.     
  354.         'ping an ip address, passing the
  355.         'address and the ECHO structure
  356.         Call PingAddress((hostnameOrIpaddress), echoValues, timeOutmSec)
  357.         
  358.         If left$(echoValues.data, 1) <> chr$(0) Then
  359.            pos = InStr(echoValues.data, chr$(0))
  360.            echoValues.data = left$(echoValues.data, pos - 1)
  361.         Else
  362.               echoValues.data = ""
  363.         End If
  364.              
  365.         SocketsCleanup
  366.         
  367.         If echoValues.Status <> 0 Then
  368.             Ping = False
  369.         Else
  370.             Ping = True
  371.         End If
  372.     End If
  373.     Exit Function
  374. e_Trap:
  375.     Ping = False
  376. End Function
  377.  
  378. Public Function ResolveIpaddress(ByVal hostname As String) As Collection
  379. Dim hostent_addr As Long
  380. Dim Host As Hostent
  381. Dim hostip_addr As Long
  382. Dim temp_ip_address() As Byte
  383. Dim i As Integer
  384. Dim ip_address As String
  385. Dim Count As Integer
  386.  
  387.     If SocketsInitialize() Then
  388.     
  389.         Set ResolveIpaddress = New Collection
  390.         hostent_addr = gethostbyname(hostname)
  391.         
  392.         If hostent_addr = 0 Then
  393.             SocketsCleanup
  394.             Exit Function
  395.         End If
  396.         
  397.         RtlMoveMemory Host, hostent_addr, LenB(Host)
  398.         RtlMoveMemory hostip_addr, Host.hAddrList, 4
  399.         
  400.         'get all of the IP address if machine is  multi-homed
  401.         
  402.         Do
  403.             ReDim temp_ip_address(1 To Host.hLength)
  404.             RtlMoveMemory temp_ip_address(1), hostip_addr, Host.hLength
  405.         
  406.             For i = 1 To Host.hLength
  407.                 ip_address = ip_address & temp_ip_address(i) & "."
  408.             Next
  409.             ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
  410.             ResolveIpaddress.Add ip_address
  411.             ip_address = ""
  412.             Host.hAddrList = Host.hAddrList + LenB(Host.hAddrList)
  413.             RtlMoveMemory hostip_addr, Host.hAddrList, 4
  414.          Loop While (hostip_addr <> 0)
  415.     
  416.         SocketsCleanup
  417.     End If
  418. End Function
  419. Public Function ResolveHostname(ByVal ipaddress As String) As String
  420.  
  421. Dim hostip_addr As Long
  422. Dim hostent_addr As Long
  423. Dim newAddr As Long
  424. Dim Host As Hostent
  425. Dim strTemp As String
  426. Dim strHost As String * 255
  427.  
  428.     If SocketsInitialize() Then
  429.         newAddr = inet_addr(ipaddress)
  430.         hostent_addr = gethostbyaddr(newAddr, Len(newAddr), AF_INET)
  431.  
  432.         If hostent_addr = 0 Then
  433.             SocketsCleanup
  434.             Exit Function
  435.         End If
  436.  
  437.         RtlMoveMemory Host, hostent_addr, Len(Host)
  438.         RtlMoveMemory ByVal strHost, Host.hName, 255
  439.         strTemp = strHost
  440.         If InStr(strTemp, chr(0)) <> 0 Then strTemp = left(strTemp, InStr(strTemp, chr(0)) - 1)
  441.         strTemp = Trim(strTemp)
  442.         ResolveHostname = strTemp
  443.         SocketsCleanup
  444.  
  445.     End If
  446. End Function
  447.