Attribute VB_Name = "modMXQuery"

Option Explicit

' winsock
Private Const DNS_RECURSION As Byte = 1
Private Const AF_INET = 2
Private Const SOCKET_ERROR = -1
Private Const ERROR_BUFFER_OVERFLOW = 111
Private Const SOCK_DGRAM = 2
Private Const INADDR_NONE = &HFFFFFFFF
Private Const INADDR_ANY = &H0
' registry access
Private Const REG_SZ = 1&
Private Const ERROR_SUCCESS = 0&
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
Private Const KEY_NOTIFY = &H10&
Private Const READ_CONTROL = &H20000
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_READ = READ_CONTROL
Private Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY

' winsock
Private Type WSADATA
    wVersion                As Integer
    wHighVersion            As Integer
    szDescription(256)      As Byte
    szSystemStatus(128)     As Byte
    iMaxSockets             As Integer
    iMaxUdpDg               As Integer
    lpVendorInfo            As Long
End Type

Private Type DNS_HEADER
    qryID                   As Integer
    options                 As Byte
    response                As Byte
    qdcount                 As Integer
    ancount                 As Integer
    nscount                 As Integer
    arcount                 As Integer
End Type

Private Type IP_ADDRESS_STRING
    IpAddressStr(4 * 4 - 1) As Byte
End Type
 
Private Type IP_MASK_STRING
    IpMaskString(4 * 4 - 1) As Byte
End Type
 
Private Type IP_ADDR_STRING
    Next                    As Long
    IpAddress               As IP_ADDRESS_STRING
    IpMask                  As IP_MASK_STRING
    Context                 As Long
End Type

Private Type FIXED_INFO
    HostName(128 + 4 - 1)   As Byte
    DomainName(128 + 4 - 1) As Byte
    CurrentDnsServer        As Long
    DnsServerList           As IP_ADDR_STRING
    NodeType                As Long
    ScopeId(256 + 4 - 1)    As Byte
    EnableRouting           As Long
    EnableProxy             As Long
    EnableDns               As Long
End Type

Private Type SOCKADDR
    sin_family              As Integer
    sin_port                As Integer
    sin_addr                As Long
    sin_zero                As String * 8
End Type

Private Type HostEnt
    h_name                  As Long
    h_aliases               As Long
    h_addrtype              As Integer
    h_length                As Integer
    h_addr_list             As Long
End Type

' registry
Private Type FILETIME
    dwLowDateTime           As Long
    dwHighDateTime          As Long
End Type

' public type for passing DNS info
Public Type DNS_INFO
    Servers()               As String
    Count                   As Long
    LocalDomain             As String
    RootDomain              As String
End Type

' used below
Public Type MX_RECORD
    Server                  As String
    Pref                    As Integer
End Type

' public type for passing MX info
Public Type MX_INFO
    Best                    As String
    Domain                  As String
    List()                  As MX_RECORD
    Count                   As Long
End Type

Public DNS                  As DNS_INFO
Public MX                   As MX_INFO


' API prototypes

' winsock, 'wsock32.dll' used instead of 'ws2_32.dll' for wider compatibility
Private Declare Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) 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 inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
Private Declare Function recvfrom Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long, from As SOCKADDR, fromlen As Long) As Long
Private Declare Function socket Lib "wsock32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Private Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
Private Declare Function ntohs Lib "wsock32.dll" (ByVal netshort As Long) As Integer
Private Declare Function sendto Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long, to_addr As SOCKADDR, ByVal tolen 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

' Registry access
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long

' misc
Private Declare Function GetNetworkParams Lib "iphlpapi.dll" (pFixedInfo As Any, pOutBufLen As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long


Public Sub GetDNSInfo()

    ' get the DNS servers and the local IP Domain name
    
    Dim sBuffer                 As String
    Dim sDNSBuff                As String
    Dim sDomainBuff             As String
    Dim sKey                    As String
    Dim lngFixedInfoNeeded      As Long
    Dim bytFixedInfoBuffer()    As Byte
    Dim udtFixedInfo            As FIXED_INFO
    Dim lngIpAddrStringPtr      As Long
    Dim udtIpAddrString         As IP_ADDR_STRING
    Dim strDnsIpAddress         As String
    Dim nRet                    As Long
    Dim sTmp()                  As String
    Dim I                       As Long
       
    ' get dns servers with the new GetNetworkParams call (only works on 98/ME/2000)
    ' if GetNetworkParams is not supported then try reading from the registry
    If Exported("iphlpapi.dll", "GetNetworkParams") Then
        nRet = GetNetworkParams(ByVal vbNullString, lngFixedInfoNeeded)
        If nRet = ERROR_BUFFER_OVERFLOW Then
            ReDim bytFixedInfoBuffer(lngFixedInfoNeeded)
            nRet = GetNetworkParams(bytFixedInfoBuffer(0), lngFixedInfoNeeded)
            CopyMemory udtFixedInfo, bytFixedInfoBuffer(0), Len(udtFixedInfo)
            With udtFixedInfo
                ' get the DNS servers
                lngIpAddrStringPtr = VarPtr(.DnsServerList)
                Do While lngIpAddrStringPtr
                    CopyMemory udtIpAddrString, ByVal lngIpAddrStringPtr, Len(udtIpAddrString)
                    With udtIpAddrString
                        strDnsIpAddress = StripTerminator(StrConv(.IpAddress.IpAddressStr, vbUnicode))
                        sDNSBuff = sDNSBuff & strDnsIpAddress & ","
                        lngIpAddrStringPtr = .Next
                    End With
                Loop
                ' get the ip domain name
                sDomainBuff = StripTerminator(StrConv(.DomainName, vbUnicode))
            End With
        End If
    End If
    
    ' if GetNetworkParams didn't get the data we need,
    ' try known locations in the registry for DNS & domain info
    If Len(sDNSBuff) = 0 Or Len(sDomainBuff) = 0 Then

        ' DNS servers configured through Network control panel applet (95/98/ME)
        sKey = "System\CurrentControlSet\Services\VxD\MSTCP"
        sBuffer = GetRegStr(HKEY_LOCAL_MACHINE, sKey, "NameServer", "")
        If Len(sBuffer) Then sDNSBuff = sBuffer & ","
        sBuffer = GetRegStr(HKEY_LOCAL_MACHINE, sKey, "Domain", "")
        If Len(sBuffer) Then sDomainBuff = sBuffer

        ' DNS servers configured through Network control panel applet (NT/2000)
        sKey = "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters"
        sBuffer = GetRegStr(HKEY_LOCAL_MACHINE, sKey, "NameServer", "")
        If Len(sBuffer) Then sDNSBuff = sBuffer & ","
        sBuffer = GetRegStr(HKEY_LOCAL_MACHINE, sKey, "Domain", "")
        If Len(sBuffer) Then sDomainBuff = sBuffer

        ' DNS servers configured DHCP (NT/2000/XP)
        sKey = "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters"
        sBuffer = GetRegStr(HKEY_LOCAL_MACHINE, sKey, "DhcpNameServer", "")
        If Len(sBuffer) Then sDNSBuff = sBuffer & ","
        sBuffer = GetRegStr(HKEY_LOCAL_MACHINE, sKey, "DHCPDomain", "")
        If Len(sBuffer) Then sDomainBuff = sBuffer

        ' DNS servers configured through Network control panel applet (XP)
        sKey = "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces"
        sTmp = EnumRegKey(HKEY_LOCAL_MACHINE, sKey)
        For I = 0 To UBound(sTmp)
            sBuffer = GetRegStr(HKEY_LOCAL_MACHINE, sKey & "\" & sTmp(I), "NameServer", "")
            If Len(sBuffer) Then sDNSBuff = sBuffer & ","
            sBuffer = GetRegStr(HKEY_LOCAL_MACHINE, sKey & "\" & sTmp(I), "Domain", "")
            If Len(sBuffer) Then sDomainBuff = sBuffer
        Next
        
        ' DNS servers configured DHCP (95/98/ME)
        ' *** haven't found one ***
    
    End If

    ' get rid of any space delimiters (2000)
    sDNSBuff = Replace(sDNSBuff, " ", ",")

    ' trim any trailing commas
    If Right(sDNSBuff, 1) = "," Then sDNSBuff = Left(sDNSBuff, Len(sDNSBuff) - 1)

    ' load our type struc
    DNS.Servers = Split(sDNSBuff, ",")
    DNS.Count = UBound(DNS.Servers) + 1
    DNS.LocalDomain = sDomainBuff

    ' cheap trick
    If sDomainBuff = "" And DNS.Count > 0 Then
        sDomainBuff = GetRemoteHostName(DNS.Servers(0))
        nRet = InStr(sDomainBuff, ".")
        If nRet Then
            DNS.LocalDomain = Mid$(sDomainBuff, nRet + 1)
        End If
    End If

    sTmp = Split(sDomainBuff, ".")
    nRet = UBound(sTmp)
    If nRet > 0 Then
        DNS.RootDomain = sTmp(nRet - 1) & "." & sTmp(nRet)
    Else
        DNS.RootDomain = sDomainBuff
    End If

End Sub

Public Function MX_Query(ByVal ms_Domain As String) As String
    
    ' Performs the actual IP work to contact the DNS server,
    ' calls the other functions to parse and return the
    ' best server to send email through
    
    Dim StartupData     As WSADATA
    Dim SocketBuffer    As SOCKADDR
    Dim IpAddr          As Long
    Dim iRC             As Integer
    Dim dnsHead         As DNS_HEADER
    Dim iSock           As Integer
    Dim dnsQuery()      As Byte
    Dim sQName          As String
    Dim dnsQueryNdx     As Integer
    Dim iTemp           As Integer
    Dim iNdx            As Integer
    Dim dnsReply(2048)  As Byte
    Dim iAnCount        As Integer
    Dim dwFlags         As Long


    MX.Count = 0
    MX.Best = vbNullString
    ReDim MX.List(0)

    ' if DNSInfo hasn't been called, call it now
    If DNS.Count = 0 Then GetDNSInfo
    
    ' check to see that we found a dns server
    If DNS.Count = 0 Then
        ' problem
        Err.Raise 20000, "MXQuery", "No DNS entries found, MX Query cannot contine."
        Exit Function
    End If
   
    ' if null was passed in then use the local domain name
    If Len(ms_Domain) = 0 Then ms_Domain = DNS.LocalDomain
    
    ' validate domain name
    If Len(ms_Domain) < 5 Then
        Err.Raise 20000, "MXQuery", "No Valid Domain Specified"
        Exit Function
    End If
   
    MX.Domain = ms_Domain
   
    ' Initialize the Winsock, request v1.1
    If WSAStartup(&H101, StartupData) <> ERROR_SUCCESS Then
        iRC = WSACleanup
        Exit Function
    End If
    
    ' Create a socket
    iSock = socket(AF_INET, SOCK_DGRAM, 0)
    If iSock = SOCKET_ERROR Then Exit Function

    ' convert the IP address string to a network ordered long
    IpAddr = GetHostByNameAlias(DNS.Servers(0))
    If IpAddr = -1 Then Exit Function
    
    ' Setup the connnection parameters
    SocketBuffer.sin_family = AF_INET
    SocketBuffer.sin_port = htons(53)
    SocketBuffer.sin_addr = IpAddr
    SocketBuffer.sin_zero = String$(8, 0)
    
    ' Set the DNS parameters
    dnsHead.qryID = htons(&H11DF)
    dnsHead.options = DNS_RECURSION
    dnsHead.qdcount = htons(1)
    dnsHead.ancount = 0
    dnsHead.nscount = 0
    dnsHead.arcount = 0
    
    dnsQueryNdx = 0
    
    ReDim dnsQuery(4000)
    
    ' Setup the dns structure to send the query in
    ' First goes the DNS header information
    CopyMemory dnsQuery(dnsQueryNdx), dnsHead, 12
    dnsQueryNdx = dnsQueryNdx + 12
    
    ' Then the domain name (as a QNAME)
    sQName = MakeQName(MX.Domain)
    iNdx = 0
    While (iNdx < Len(sQName))
        dnsQuery(dnsQueryNdx + iNdx) = Asc(Mid(sQName, iNdx + 1, 1))
        iNdx = iNdx + 1
    Wend

    dnsQueryNdx = dnsQueryNdx + Len(sQName)
    
    ' Null terminate the string
    dnsQuery(dnsQueryNdx) = &H0
    dnsQueryNdx = dnsQueryNdx + 1
    
    ' The type of query (15 means MX query)
    iTemp = htons(15)
    CopyMemory dnsQuery(dnsQueryNdx), iTemp, Len(iTemp)
    dnsQueryNdx = dnsQueryNdx + Len(iTemp)
    
    ' The class of query (1 means INET)
    iTemp = htons(1)
    CopyMemory dnsQuery(dnsQueryNdx), iTemp, Len(iTemp)
    dnsQueryNdx = dnsQueryNdx + Len(iTemp)
    
    ReDim Preserve dnsQuery(dnsQueryNdx - 1)
    ' Send the query to the DNS server
    iRC = sendto(iSock, dnsQuery(0), dnsQueryNdx + 1, 0, SocketBuffer, Len(SocketBuffer))
    If (iRC = SOCKET_ERROR) Or (iRC = 0) Then
        Err.Raise 20000, "MXQuery", "Problem sending MX query"
        iRC = WSACleanup
        Exit Function
    End If

    ' Wait for answer from the DNS server
    iRC = recvfrom(iSock, dnsReply(0), 2048, 0, SocketBuffer, Len(SocketBuffer))
    If (iRC = SOCKET_ERROR) Or (iRC = 0) Then
        Err.Raise 20000, "MXQuery", "Problem receiving MX query"
        iRC = WSACleanup
        Exit Function
    End If

    ' Get the number of answers
    CopyMemory iAnCount, dnsReply(6), 2
    iAnCount = ntohs(iAnCount)
    
    iRC = WSACleanup
    
    If iAnCount Then
        ' Parse the answer buffer