Attribute VB_Name = "modDNS"
Option Explicit
Public Enum IP_STATUS
    IP_STATUS_Base = 11000
    IP_SUCCESS = 0
    IP_BUF_TOO_SMALL = (11000 + 1)
    IP_DEST_NET_UNREACHABLE = (11000 + 2)
    IP_DEST_HOST_UNREACHABLE = (11000 + 3)
    IP_DEST_PROT_UNREACHABLE = (11000 + 4)
    IP_DEST_PORT_UNREACHABLE = (11000 + 5)
    IP_NO_RESOURCES = (11000 + 6)
    IP_BAD_Option = (11000 + 7)
    IP_HW_Error = (11000 + 8)
    IP_PACKET_TOO_BIG = (11000 + 9)
    IP_REQ_TIMED_OUT = (11000 + 10)
    IP_BAD_REQ = (11000 + 11)
    IP_BAD_ROUTE = (11000 + 12)
    IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
    IP_TTL_EXPIRED_REASSEM = (11000 + 14)
    IP_PARAM_PROBLEM = (11000 + 15)
    IP_SOURCE_QUENCH = (11000 + 16)
    IP_Option_TOO_BIG = (11000 + 17)
    IP_BAD_DESTINATION = (11000 + 18)
    IP_ADDR_DELETED = (11000 + 19)
    IP_SPEC_MTU_CHANGE = (11000 + 20)
    IP_MTU_CHANGE = (11000 + 21)
    IP_Unload = (11000 + 22)
    IP_ADDR_ADDED = (11000 + 23)
    IP_GENERAL_FAILURE = (11000 + 50)
    MAX_IP_STATUS = 11000 + 50
    IP_PENDING = (11000 + 255)
    PING_TIMEOUT = 200
End Enum
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const Error_SUCCESS       As Long = 0
Private Const WS_VERSION_REQD     As Long = &H101
Private Const WS_VERSION_MAJOR    As Long = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR    As Long = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD    As Long = 1
Private Const SOCKET_Error        As Long = -1
Public Type ICMP_OPTIONS
    Ttl             As Byte
    Tos             As Byte
    Flags           As Byte
    OptionsSize     As Byte
    OptionsData     As Long
End Type
Dim ICMPOPT As ICMP_OPTIONS
Public Type ICMP_ECHO_REPLY
    Address         As Long
    Status          As Long
    RoundTripTime   As Long
    DataSize        As Long
    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 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
Private Declare Function gethostbyaddr Lib "wsock32.dll" (ByRef dwHost As Long, ByVal hLen As Integer, ByVal aType As Integer) As Long
Private Declare Function inet_addr Lib "wsock32.dll" (ByVal szHost As String) As Long
Private Declare Function lstrlen Lib "kernel32" (ByVal lpString As Long) As Long
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 Long, 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, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "wsock32.dll" (ByVal szHost As String) As Long
Private Function HiByte(ByVal wParam As Integer)
    On Error GoTo Erred
    HiByte = wParam \ &H1 And &HFF&
Exit Function
Erred:
    ErrorHandler "DNS", "HiByte " & wParam
    Resume Next
End Function
Private Function LoByte(ByVal wParam As Integer)
    On Error GoTo Erred
    LoByte = wParam And &HFF&
Exit Function
Erred:
    ErrorHandler "DNS", "LoByte " & wParam
    Resume Next
End Function
Private Sub SocketsCleanup()
    On Error GoTo Erred
    If WSACleanup <> Error_SUCCESS Then
        App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
    End If
Exit Sub
Erred:
    ErrorHandler "DNS", "SocketsCleanup"
    Resume Next
End Sub
Private Function SocketsInitialize(Optional sErr As String) As Boolean
Dim WSAD    As WSADATA
Dim sLoByte As String
Dim sHiByte As String
    On Error GoTo Erred
    If WSAStartup(WS_VERSION_REQD, WSAD) <> Error_SUCCESS Then
        sErr = "The 32-bit Windows Socket is not responding."
        SocketsInitialize = False
        Exit Function
    End If
    If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        sErr = "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets."
        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
        sHiByte = CStr(HiByte(WSAD.wVersion))
        sLoByte = CStr(LoByte(WSAD.wVersion))
        sErr = "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets."
        SocketsInitialize = False
        Exit Function
    End If
    SocketsInitialize = True
Exit Function
Erred:
    ErrorHandler "DNS", "SocketsInitialize"
    Resume Next
End Function
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
Dim dwAddress As Long
Dim iOpt      As Long
    On Error GoTo Erred
    dwAddress = AddressStringToLong(szAddress)
    hPort = IcmpCreateFile
    If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, ECHO, Len(ECHO), TimeOut) Then
        DoPing = IP_SUCCESS
    Else
        If ECHO.Status = 0 Then
            DoPing = -1
        Else
            DoPing = ECHO.Status * -1
        End If
    End If
    Call IcmpCloseHandle(hPort)
Exit Function
Erred:
    ErrorHandler "DNS", "DoPing"
    Resume Next
End Function
Public Function AddressStringToLong(ByVal tmp As String) As Long
Dim I             As Integer
Dim parts(1 To 4) As String
    On Error GoTo Erred
    I = 0
    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
    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))
Exit Function
Erred:
    ErrorHandler "DNS", "AddressStringToLong " & tmp
    Resume Next
End Function
Public Function GetStatusCode(Status As IP_STATUS) As String
Dim msg As String
    On Error GoTo Erred
    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 Request 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
    GetStatusCode = msg
Exit Function
Erred:
    ErrorHandler "DNS", "GetStatusCode"
    Resume Next
End Function
Public Function GetIPAddress(Optional sHost As String, Optional serrmsg As String) As String
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
    On Error GoTo Erred
    If Not SocketsInitialize Then
        GetIPAddress = ""
    Else
        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
        RtlMoveMemory Host, ByVal lpHost, Len(Host)
        RtlMoveMemory dwIPAddr, ByVal Host.hAddrList, 4
        ReDim tmpIPAddr(1 To Host.hLen)
        RtlMoveMemory tmpIPAddr(1), ByVal dwIPAddr, Host.hLen
        For I = 1 To Host.hLen
            sIPAddr = sIPAddr & tmpIPAddr(I) & "."
        Next
        GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
        SocketsCleanup
    End If
Exit Function
Erred:
    ErrorHandler "DNS", "GetIPAddress"
    Resume Next
End Function
Public Function GetIPHostName() As String
Dim sHostName As String * 256
    On Error GoTo Erred
    If Not SocketsInitialize Then
        GetIPHostName = ""
    Else
        If gethostname(sHostName, 256) = SOCKET_Error Then
            GetIPHostName = ""
            SocketsCleanup
        Else
            GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
            SocketsCleanup
        End If
    End If
Exit Function
Erred:
    ErrorHandler "DNS", "GetIPHostName"
    Resume Next
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
Dim pos      As Integer
Dim Dt       As String
Dim 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 = DoPing(sAddress, Dt, ECHO, TimeOut)
        RoundTripTime = ECHO.RoundTripTime & " ms"
        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
Dim Buffer() As Byte
Dim nLen As Long
    On Error GoTo Erred
    If lpString Then
        nLen = lstrlen(lpString)
        If nLen Then
            ReDim Buffer(0 To (nLen - 1)) As Byte
            RtlMoveMemory Buffer(0), ByVal lpString, nLen
            PointerToString = StrConv(Buffer, vbUnicode)
        End If
    End If
Exit Function
Erred:
    ErrorHandler "DNS", "PointerToString " & lpString
    Resume Next
End Function
Public Function GetHostFromIP(sIPAddr As String, Optional serrmsg As String) As String
Dim dwIPAddr As Long
Dim lpHost   As Long
Dim Host     As HOSTENT
Dim werr     As Long
    If Not SocketsInitialize Then
        GetHostFromIP = ""
    Else
        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
        Else
            RtlMoveMemory Host, ByVal lpHost, Len(Host)
            GetHostFromIP = PointerToString(Host.hName)
            SocketsCleanup
        End If
    End If
Exit Function
Erred:
    ErrorHandler "DNS", "GetHostFromIP " & sIPAddr
    Resume Next
End Function
Public Function GetIPFromHostName(ByVal sHostName As String) As String
Dim nbytes       As Long
Dim ptrHosent    As Long
Dim ptrName      As Long
Dim ptrAddress   As Long
Dim ptrIPAddress As Long
Dim sAddress     As String
    On Error GoTo Erred
    If Not SocketsInitialize Then
        GetIPFromHostName = ""
    Else
        sAddress = Space$(4)
        ptrHosent = gethostbyname(sHostName & vbNullChar)
        If ptrHosent <> 0 Then
            ptrName = ptrHosent
            ptrAddress = ptrHosent + 12
            RtlMoveMemory ptrName, ByVal ptrName, 4
            RtlMoveMemory ptrAddress, ByVal ptrAddress, 4
            RtlMoveMemory ptrIPAddress, ByVal ptrAddress, 4
            RtlMoveMemory ByVal sAddress, ByVal ptrIPAddress, 4
            GetIPFromHostName = sAddress
        End If
        SocketsCleanup
    End If
Exit Function
Erred:
    ErrorHandler "DNS", "GetIPFromHostName " & sHostName
    Resume Next
End Function