Option Compare Database
Option Explicit

Const WSADESCRIPTION_LEN = 256
Const WSASYS_Status_Len = 128
Const PING_TIMEOUT = 500

Private Type hostent
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLength As Integer
    hAddrList As Long
End Type
Private Type WSADATA
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To WSADESCRIPTION_LEN) As Byte
    szSystemStatus(0 To WSASYS_Status_Len) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpszVendorInfo As Long
End Type

Private Type IP_OPTION_INFORMATION
    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 IP_OPTION_INFORMATION
    Data As String * 128
End Type

Private Declare Function WSAStartup Lib "wsock32" _
    (ByVal VersionReq As Long, WSADataReturn As WSADATA) As Long
Private Declare Function WSACleanup Lib "wsock32" () As Long
Private Declare Function WSAGetLastError Lib "wsock32" () As Long
Private Declare Function gethostbyaddr Lib "wsock32" (addr As Long, addrLen As Long, _
    addrType As Long) As Long
Private Declare Function GetHostByName Lib "wsock32" Alias "gethostbyname" (ByVal HostName As String) As Long
Private Declare Sub RtlMoveMemory Lib "Kernel32" (hpvDest As Any, ByVal hpvSource As Long, _
    ByVal cbCopy As Long)
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
    (ByVal HANDLE As Long) As Boolean
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

'Public Event Error(ByVal Number As Long, Description As String)
'Public Event ResolveCompleted()

'Comments  : checks if string is valid IP address
'Parameters:
'Sets      :
'Returns   :
'Created by: Unknown
'Mod. by   : Seth D. Galitzer
'Created   : 7/20/00 9:23:26 AM
Private Function IsIP(ByVal strIP As String) As Boolean
On Error GoTo Err_IsIP
    On Error Resume Next
    Dim t As String: Dim s As String: Dim i As Integer
    s = strIP
    While InStr(s, ".") <> 0
        t = Left(s, InStr(s, ".") - 1)
        If IsNumeric(t) And Val(t) >= 0 And Val(t) <= 255 Then s = Mid(s, InStr(s, ".") + 1) _
        Else Exit Function
        i = i + 1
    Wend
    t = s
    If IsNumeric(t) And InStr(t, ".") = 0 And Len(t) = Len(Trim(Str(Val(t)))) And _
        Val(t) >= 0 And Val(t) <= 255 And strIP <> "255.255.255.255" And i = 3 Then IsIP = True
Exit_IsIP:
Exit Function

Err_IsIP:
    Select Case Err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        Beep
        MsgBox Err & ": " & Err.Description, , "Error in function clsIP_Tools.IsIP"
    Resume Exit_IsIP
    End Select
    Resume 0    'FOR TROUBLESHOOTING
End Function

'Comments  : converts IP address from string to sin_addr
'Parameters:
'Sets      :
'Returns   :
'Created by: Unknown
'Mod. by   : Seth D. Galitzer
'Created   : 7/20/00 9:24:53 AM
Private Function MakeIP(ByVal strIP As String) As Long
On Error GoTo Err_MakeIP
    On Error Resume Next
    Dim lIP As Long
    lIP = Left(strIP, InStr(strIP, ".") - 1)
    strIP = Mid(strIP, InStr(strIP, ".") + 1)
    lIP = lIP + Left(strIP, InStr(strIP, ".") - 1) * 256
    strIP = Mid(strIP, InStr(strIP, ".") + 1)
    lIP = lIP + Left(strIP, InStr(strIP, ".") - 1) * 256 * 256
    strIP = Mid(strIP, InStr(strIP, ".") + 1)
    If strIP < 128 Then
        lIP = lIP + strIP * 256 * 256 * 256
    Else
        lIP = lIP + (strIP - 256) * 256 * 256 * 256
    End If
    MakeIP = lIP
Exit_MakeIP:
Exit Function

Err_MakeIP:
    Select Case Err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        Beep
        MsgBox Err & ": " & Err.Description, , "Error in function clsIP_Tools.MakeIP"
    Resume Exit_MakeIP
    End Select
    Resume 0    'FOR TROUBLESHOOTING
End Function

'Comments  : resolves IP address to host name
'Parameters:
'Sets      :
'Returns   :
'Created by: Unknown
'Mod. by   : Seth D. Galitzer
'Created   : 7/20/00 9:25:33 AM
Private Function NameByAddr(strAddr As String) As String
On Error GoTo Err_NameByAddr
    On Error Resume Next
    Dim nRet As Long
    Dim lIP As Long
    Dim strHost As String * 255
    Dim strTemp As String
    Dim hst As hostent
  
    strHost = String(255, 0)
    If IsIP(strAddr) Then
        lIP = MakeIP(strAddr)
        nRet = gethostbyaddr(lIP, 4, 2)
        If nRet <> 0 Then
            RtlMoveMemory hst, nRet, Len(hst)
            RtlMoveMemory ByVal strHost, hst.hName, 255
            strTemp = strHost
            strTemp = Left(strTemp, InStr(strTemp, Chr(0)) - 1)
            strTemp = Trim(strTemp)
            NameByAddr = strTemp
        Else
            Err.Raise 9003, , "Host name not found"
        End If
    Else
        Err.Raise 9002, , "Invalid IP address"
    End If
Exit_NameByAddr:
Exit Function

Err_NameByAddr:
    Select Case Err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        Beep
        MsgBox Err & ": " & Err.Description, , "Error in function clsIP_Tools.NameByAddr"
    Resume Exit_NameByAddr
    End Select
    Resume 0    'FOR TROUBLESHOOTING
End Function

'Comments  : resolves host name to IP address
'Parameters:
'Sets      :
'Returns   :
'Created by: Unknown
'Mod. by   : Seth D. Galitzer
'Created   : 7/20/00 9:27:00 AM
Private Function AddrByName(ByVal strHost As String) As String
On Error GoTo Err_AddrByName
    On Error Resume Next
    Dim hostent_addr As Long
    Dim hst As hostent
    Dim hostip_addr As Long
    Dim temp_ip_address() As Byte
    Dim i As Integer
    Dim ip_address As String
    If IsIP(strHost) Then
        AddrByName = strHost
        Exit Function
    End If
    hostent_addr = GetHostByName(strHost)
    If hostent_addr = 0 Then
        Err.Raise 9001, , "Can't resolve host"
    End If
    RtlMoveMemory hst, hostent_addr, LenB(hst)
    RtlMoveMemory hostip_addr, hst.hAddrList, 4
    ReDim temp_ip_address(1 To hst.hLength)
    RtlMoveMemory temp_ip_address(1), hostip_addr, hst.hLength
    For i = 1 To hst.hLength
        ip_address = ip_address & temp_ip_address(i) & "."
    Next
    ip_address = Mid(ip_address, 1, Len(ip_address) - 1)
    AddrByName = ip_address
Exit_AddrByName:
Exit Function

Err_AddrByName:
    Select Case Err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        Beep
        MsgBox Err & ": " & Err.Description, , "Error in function clsIP_Tools.AddrByName"
    Resume Exit_AddrByName
    End Select
    Resume 0    'FOR TROUBLESHOOTING
End Function

Public Function AddressToName(strIP As String) As String
    AddressToName = NameByAddr(strIP)
End Function

Public Function NameToAddress(strName As String) As String
    NameToAddress = AddrByName(strName)
End Function

'Comments  :
'Parameters:
'Created by: Unknown
'Mod. by   : Seth D. Galitzer
'Created   : 7/20/00 9:30:37 AM
Private Sub Class_Initialize()
On Error GoTo Err_Class_Initialize
    Dim udtWSAData As WSADATA
    If WSAStartup(257, udtWSAData) Then
        Err.Raise Err.LastDllError, , Err.Description
    End If
Exit_Class_Initialize:
Exit Sub

Err_Class_Initialize:
    Select Case Err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        Beep
        MsgBox Err & ": " & Err.Description, , "Error in function clsIP_Tools.Class_Initialize"
    Resume Exit_Class_Initialize
    End Select
    Resume 0    'FOR TROUBLESHOOTING
End Sub

Private Sub Class_Terminate()
    WSACleanup
End Sub

'Comments  : Ping an IP Address
'Parameters:
'Sets      :
'Returns   :
'Created by: Unknown
'Mod. by   : Seth D. Galitzer
'Created   : 7/20/00 9:31:50 AM
Public Function Ping(IPAddress As String) As Boolean
On Error GoTo Err_Ping
    On Error Resume Next
    Dim hFile As Long
    Dim lRet As Long
    Dim lIPAddress As Long
    Dim strMessage As String
    'Dim pOptions As IP_OPTION_INFORMATION
    Dim pReturn As ICMP_ECHO_REPLY
    Dim iVal As Integer
    Dim lPingRet As Long
    strMessage = "X"
    lIPAddress = ConvertIPAddressToLong(IPAddress$)
    hFile = IcmpCreateFile()
    'pOptions.TTL = 30
    'pOptions.Tos = 0
    lRet = IcmpSendEcho(hFile, lIPAddress, strMessage, _
        Len(strMessage), 0, pReturn, Len(pReturn), PING_TIMEOUT)

    If lRet = 0 Then
        Ping = False
    Else
        If pReturn.Status <> 0 Then
            Ping = False
        Else
            Ping = True
        End If
    End If
    lRet = IcmpCloseHandle(hFile)
Exit_Ping:
Exit Function

Err_Ping:
    Select Case Err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        Beep
        MsgBox Err & ": " & Err.Description, , "Error in function clsIP_Tools.Ping"
    Resume Exit_Ping
    End Select
    Resume 0    'FOR TROUBLESHOOTING
End Function

'Comments  : For Ping: It changes the IP Address so it can be used to send the ping
'Parameters:
'Sets      :
'Returns   :
'Created by: Unknown
'Mod. by   : Seth D. Galitzer
'Created   : 7/20/00 9:32:03 AM
Private Function ConvertIPAddressToLong(strAddress As String) As Long
On Error GoTo Err_ConvertIPAddressToLong
    On Error Resume Next
    Dim strTemp As String
    Dim lAddress As Long
    Dim iValCount As Integer
    Dim lDotValues(1 To 4) As String
    strTemp = strAddress
    iValCount = 0

    While InStr(strTemp, ".") > 0
        iValCount = iValCount + 1
        lDotValues(iValCount) = Mid(strTemp, 1, InStr(strTemp, ".") - 1)
        strTemp = Mid(strTemp, InStr(strTemp, ".") + 1)
    Wend
    iValCount = iValCount + 1
    lDotValues(iValCount) = strTemp


    If iValCount <> 4 Then
        ConvertIPAddressToLong = 0
        Exit Function
    End If
    lAddress = Val("&H" & Right("00" & Hex(lDotValues(4)), 2) & _
    Right("00" & Hex(lDotValues(3)), 2) & _
    Right("00" & Hex(lDotValues(2)), 2) & _
    Right("00" & Hex(lDotValues(1)), 2))
    ConvertIPAddressToLong = lAddress
Exit_ConvertIPAddressToLong:
Exit Function

Err_ConvertIPAddressToLong:
    Select Case Err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        Beep
        MsgBox Err & ": " & Err.Description, , "Error in function clsIP_Tools.ConvertIPAddressToLong"
    Resume Exit_ConvertIPAddressToLong
    End Select
    Resume 0    'FOR TROUBLESHOOTING
End Function