Attribute VB_Name = "modReverseDns"
Option Explicit

Public Const ERROR_BUFFER_OVERFLOW = 111&
Public Const ERROR_INVALID_PARAMETER = 87
Public Const ERROR_NO_DATA = 232&
Public Const ERROR_NOT_SUPPORTED = 50&
Public Const ERROR_SUCCESS = 0&

Public Const MIB_TCP_STATE_CLOSED = 1
Public Const MIB_TCP_STATE_LISTEN = 2
Public Const MIB_TCP_STATE_SYN_SENT = 3
Public Const MIB_TCP_STATE_SYN_RCVD = 4
Public Const MIB_TCP_STATE_ESTAB = 5
Public Const MIB_TCP_STATE_FIN_WAIT1 = 6
Public Const MIB_TCP_STATE_FIN_WAIT2 = 7
Public Const MIB_TCP_STATE_CLOSE_WAIT = 8
Public Const MIB_TCP_STATE_CLOSING = 9
Public Const MIB_TCP_STATE_LAST_ACK = 10
Public Const MIB_TCP_STATE_TIME_WAIT = 11
Public Const MIB_TCP_STATE_DELETE_TCB = 12

Private Const INADDR_NONE = &HFFFF
Private Const SOCKET_ERROR = -1
Private Const WSABASEERR = 10000
Private Const WSAEFAULT = (WSABASEERR + 14)
Private Const WSAEINVAL = (WSABASEERR + 22)
Private Const WSAEINPROGRESS = (WSABASEERR + 50)
Private Const WSAENETDOWN = (WSABASEERR + 50)
Private Const WSASYSNOTREADY = (WSABASEERR + 91)
Private Const WSAVERNOTSUPPORTED = (WSABASEERR + 92)
Private Const WSANOTINITIALISED = (WSABASEERR + 93)
Private Const WSAHOST_NOT_FOUND = 11001
Private Const WSADESCRIPTION_LEN = 257
Private Const WSASYS_STATUS_LEN = 129
Private Const WSATRY_AGAIN = 11002
Private Const WSANO_RECOVERY = 11003
Private Const WSANO_DATA = 11004
Private Const WSAEINTR = 10004&

' Address types for gethostbyaddr()
Private Const AF_INET = 2
Private Const PF_INET = AF_INET

Public Type MIB_TCPROW
    dwState         As Long
    dwLocalAddr     As Long
    dwLocalPort     As Long
    dwRemoteAddr    As Long
    dwRemotePort    As Long
End Type

Public Type WSAData
    wVersion        As Integer
    wHighVersion    As Integer
    szDescription   As String * WSADESCRIPTION_LEN
    szSystemStatus  As String * WSASYS_STATUS_LEN
    iMaxSockets     As Integer
    iMaxUdpDg       As Integer
    lpVendorInfo    As Long
End Type

Public Type HOSTENT
    hName       As Long
    hAliases    As Long
    hAddrType   As Integer
    hLength     As Integer
    hAddrList   As Long
End Type

Public Declare Function GetTcpTable Lib "iphlpapi.dll" (ByRef pTcpTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDest As Any, ByRef pSource As Any, ByVal length As Long)

Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long

Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVR As Long, lpWSAD As WSAData) As Long

Private Declare Function gethostbyaddr Lib "ws2_32.dll" (addr As Long, ByVal addr_len As Long, _
    ByVal addr_type As Long) As Long

Private Declare Function gethostbyname Lib "ws2_32.dll" (ByVal host_name As String) As Long

Private Declare Function gethostname Lib "ws2_32.dll" (ByVal host_name As String, _
    ByVal namelen As Long) As Long

Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long

Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, _
    ByVal hpvSource As Long, ByVal cbCopy As Long)

Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal _
    lpString1 As String, ByVal lpString2 As Long) As Long

Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal _
    lpString As Any) As Long

' This function copies a String from the position in memory
' referenced by the pointer lPointer
Public Function StringFromPointer(ByVal lPointer As Long) As String
    Dim sTemp As String
    Dim lRetVal As Long
    
    ' Prepare the sTemp buffer by checking how long the string
    ' in memory is and padding sTemp with the NUL character
    sTemp = String$(lstrlen(ByVal lPointer), 0)
    
    ' Copy the string from memory into the sTemp buffer
    lRetVal = lstrcpy(ByVal sTemp, ByVal lPointer)
    
    ' If we were successful (lstrcpy returns NUL if failed, a long
    ' pointer to the buffer if not) then return a string
    If lRetVal Then StringFromPointer = sTemp
End Function

' This function returns the hostname associated with an IP Address
' if successful, or the IP Address if no hostname could be found
' for the IP.

' If an invalid IP is given the function returns Chr(0).  Note that
' "123" or "123.123" (etc) are not considered invalid IPs, but "aa"
' is.

' If an unspecified error occurs the function returns Chr(255), you
' can then use ShowErrorMsg(Err.LastDllError) to see what it was

Public Function GetHost(IPAddress As String) As String
    ' The IP address as a Long value returned by
    ' the inet_addr() function
    Dim lInetAdr As Long
    
    ' Pointer to the HOSTENT structure
    Dim lPtrHostEnt As Long
    
    ' The hostname we are looking for
    Dim sHostname As String
    
    ' The HOSTENT structure itself
    Dim uHostEnt As HOSTENT
    
    ' The IP address in dotted notation
    Dim sIpAddress As String
    
    ' Set the hostname to nothing initially
    sHostname = vbNullString
    
    ' Remove leading/trailing spaces from the IP address
    sIpAddress = Trim$(IPAddress)
    
    ' Convert the IP address string to a Long
    lInetAdr = inet_addr(sIpAddress)

    ' If the IP address is in wrong format then the inet_addr
    ' function returns INADDR_NONE value
    If lInetAdr = INADDR_NONE Then
        GetHost = Chr(0)
        Exit Function
        
    ' If the inet_addr returned a valid Long value then continue
    ' on to get the hostname
    Else
        ' Get a pointer to the HOSTENT structure
        lPtrHostEnt = gethostbyaddr(lInetAdr, 4, PF_INET)
        
        ' If there is a problem gethostbyaddr returns NULL
        If lPtrHostEnt = 0 Then
            ' WSANO_DATA indicates there was no record for this
            ' IP, ie no hostname
            If Err.LastDllError = WSANO_DATA Then
                GetHost = IPAddress
                Exit Function
                
            ' If not there has been some other sort of error, so
            ' return Chr(255)
            Else
                GetHost = Chr(255)
                Exit Function
            End If
        Else
            ' Copy data into the HOSTENT structure
            RtlMoveMemory uHostEnt, ByVal lPtrHostEnt, LenB(uHostEnt)
            
            ' Prepare the buffer to receive a string
            sHostname = String(256, 0)
            
            ' Copy the hostname into the sHostName variable
            RtlMoveMemory ByVal sHostname, ByVal uHostEnt.hName, 256
            
            ' Trim off NULLs from end of sHostName
            sHostname = Left(sHostname, InStr(1, sHostname, Chr(0)) - 1)
            
            ' Return the found hostname
            GetHost = sHostname
        End If
    End If
End Function

' This function cleans up all references to Windows Sockets
Public Sub Cleanup()
    Call WSACleanup
End Sub

' This function initiates the use of Windows Sockets by our
' program
Public Sub InitWSA()
    
    Dim lngRetVal As Long
    Dim strErrorMsg As String
    Dim udtWinsockData As WSAData
    Dim lngType As Long
    Dim lngProtocol As Long

    ' Start up the Winsock service
    lngRetVal = WSAStartup(&H101, udtWinsockData)
    
    ' WSAStartup returns 0 if successful, or the error code
    If lngRetVal <> 0 Then
        
        Select Case lngRetVal
            Case WSASYSNOTREADY
                strErrorMsg = "The underlying network subsystem is not " & _
                    "ready for network communication."
            Case WSAVERNOTSUPPORTED
                strErrorMsg = "The version of Windows Sockets API support " & _
                    "requested is not provided by this particular " & _
                    "Windows Sockets implementation."
            Case WSAEINVAL
                strErrorMsg = "The Windows Sockets version specified by the " & _
                    "application is not supported by this DLL."
        End Select
        
        ' Alert the user of the error
        MsgBox strErrorMsg, vbCritical, "Error"
    End If
End Sub

' This function can be used to display an error message if GetHost
' fails for some reason
Public Sub ShowErrorMsg(lngError As Long)

    Dim strMessage As String
    
    Select Case lngError
        Case WSANOTINITIALISED
            strMessage = "A successful WSAStartup call must occur " & _
                         "before using this function."
        Case WSAENETDOWN
            strMessage = "The network subsystem has failed."
        Case WSAHOST_NOT_FOUND
            strMessage = "Authoritative answer host not found."
        Case WSATRY_AGAIN
            strMessage = "Nonauthoritative host not found, or server failure."
        Case WSANO_RECOVERY
            strMessage = "A nonrecoverable error occurred."
        Case WSAEINPROGRESS
            strMessage = "A blocking Windows Sockets 1.1 call is in " & _
                         "progress, or the service provider is still " & _
                         "processing a callback function."
        Case WSAEFAULT
            strMessage = "The name parameter is not a valid part of " & _
                         "the user address space."
        Case WSAEINTR
            strMessage = "A blocking Windows Socket 1.1 call was " & _
                         "canceled through WSACancelBlockingCall."
    End Select
    
    ' If we've found the right text for the error then display it
    If strMessage <> "" Then
        MsgBox strMessage, vbExclamation, "Error"
    End If
    
End Sub