MX记录获取组件（vb实现）

源码是老外的，俺做了点修改，写成了dll

方法：

Public Function GetDNSinfo() As String

获取dns信息

Public Function MX_Query(DNS_Addr As String, ByVal Domain_Addr As String) As String

获取mx最佳记录，

dns_addr,域名解析服务器，可以用getdnsinfo获取，也可以用nslookup命令

domain_addr，想要获取邮件服务器的域名，如163.com ,hotmail.com

http://www.aspcdrom.com/down/mxquery.rar

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "mxquery"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private WithEvents objWinSock As MSWinsockLib.Winsock
Attribute objWinSock.VB_VarHelpID = -1

Private Const ERROR_BUFFER_OVERFLOW = 111

Private DNSrecieved As Boolean
Private dnsReply() As Byte

Private Declare Function GetNetworkParams Lib "IPHlpApi" (FixedInfo 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 Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&)
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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const DNS_RECURSION As Byte = 1
Private Const MAX_HOSTNAME_LEN = 132
Private Const MAX_DOMAIN_NAME_LEN = 132
Private Const MAX_SCOPE_ID_LEN = 260
Private Const MAX_ADAPTER_NAME_LENGTH = 260
Private Const MAX_ADAPTER_ADDRESS_LENGTH = 8
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH = 132

Private Type IP_ADDR_STRING
            Next As Long
            IpAddress As String * 16
            IpMask As String * 16
            Context As Long
End Type

Private Type FIXED_INFO
            HostName As String * MAX_HOSTNAME_LEN
            DomainName As String * MAX_DOMAIN_NAME_LEN
            CurrentDnsServer As Long
            DnsServerList As IP_ADDR_STRING
            NodeType As Long
            ScopeId  As String * MAX_SCOPE_ID_LEN
            EnableRouting As Long
            EnableProxy As Long
            EnableDns 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 HostEnt
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Private Const hostent_size = 16

Private Type servent
    s_name As Long
    s_aliases As Long
    s_port As Integer
    s_proto As Long
End Type

Private Function MakeQName(sDomain As String) As String
    Dim iQCount As Integer      ' Character count (between dots)
    Dim iNdx As Integer         ' Index into sDomain string
    Dim iCount As Integer       ' Total chars in sDomain string
    Dim sQName As String        ' QNAME string
    Dim sDotName As String      ' Temp string for chars between dots
    Dim sChar As String         ' Single char from sDomain string
   
    iNdx = 1
    iQCount = 0
    iCount = Len(sDomain)
    ' While we haven't hit end-of-string
    While (iNdx <= iCount)
        ' Read a single char from our domain
        sChar = Mid(sDomain, iNdx, 1)
        ' If the char is a dot, then put our character count and the part of the string
        If (sChar = ".") Then
            sQName = sQName & Chr(iQCount) & sDotName
            iQCount = 0
            sDotName = ""
        Else
            sDotName = sDotName + sChar
            iQCount = iQCount + 1
        End If
        iNdx = iNdx + 1
    Wend
   
    sQName = sQName & Chr(iQCount) & sDotName
   
    MakeQName = sQName
End Function
Private Sub ParseName(dnsReply() As Byte, iNdx As Integer, sName As String)
    Dim iCompress As Integer        ' Compression index (index into original buffer)
    Dim iChCount As Integer         ' Character count (number of chars to read from buffer)
       
    ' While we didn't encounter a null char (end-of-string specifier)
    While (dnsReply(iNdx) <> 0)
        ' Read the next character in the stream (length specifier)
        iChCount = dnsReply(iNdx)
        ' If our length specifier is 192 (0xc0) we have a compressed string
        If (iChCount = 192) Then
            ' Read the location of the rest of the string (offset into buffer)
            iCompress = dnsReply(iNdx + 1)
            ' Call ourself again, this time with the offset of the compressed string
            ParseName dnsReply(), iCompress, sName
            ' Step over the compression indicator and compression index
            iNdx = iNdx + 2
            ' After a compressed string, we are done
            Exit Sub
        End If
       
        ' Move to next char
        iNdx = iNdx + 1
        ' While we should still be reading chars
        While (iChCount)
            ' add the char to our string
            sName = sName + Chr(dnsReply(iNdx))
            iChCount = iChCount - 1
            iNdx = iNdx + 1
        Wend
        ' If the next char isn't null then the string continues, so add the dot
        If (dnsReply(iNdx) <> 0) Then sName = sName + "."
    Wend
End Sub

Private Function GetMXName(dnsReply() As Byte, iNdx As Integer, iAnCount As Integer) As String
    Dim iChCount As Integer     ' Character counter
    Dim sTemp As String         ' Holds original query string
   
    Dim iMXLen As Integer
    Dim iBestPref As Integer    ' Holds the "best" preference number (lowest)
    Dim sBestMX As String       ' Holds the "best" MX record (the one with the lowest preference)
   
    iBestPref = -1
    ParseName dnsReply(), iNdx, sTemp
   
    ' Step over null
    iNdx = iNdx + 2
   
    ' Step over 6 bytes (not sure what the 6 bytes are, but all other
    '   documentation shows steping over these 6 bytes)
    iNdx = iNdx + 6
   
    On Error Resume Next
    While (iAnCount)
        ' Check to make sure we received an MX record
        If (dnsReply(iNdx) = 15) Then
            Dim sName As String
            Dim iPref As Integer
           
            sName = ""
            ' Step over the last half of the integer that specifies the record type (1 byte)

            ' Step over the RR Type, RR Class, TTL (3 integers - 6 bytes)
            iNdx = iNdx + 1 + 6
           
            ' Read the MX data length specifier
            '              (not needed, hence why it's commented out)
            MemCopy iMXLen, dnsReply(iNdx), 2
            iMXLen = ntohs(iMXLen)
           
            ' Step over the MX data length specifier (1 integer - 2 bytes)
            iNdx = iNdx + 2
           
            MemCopy iPref, dnsReply(iNdx), 2
            iPref = ntohs(iPref)
            ' Step over the MX preference value (1 integer - 2 bytes)
            iNdx = iNdx + 2
           
            ' Have to step through the byte-stream, looking for 0xc0 or 192 (compression char)
            Dim iNdx2 As Integer
            iNdx2 = iNdx
            ParseName dnsReply(), iNdx2, sName
            If (iBestPref = -1 Or iPref < iBestPref) Then
                iBestPref = iPref
                sBestMX = sName
            End If
            iNdx = iNdx + iMXLen + 1
            ' Step over 3 useless bytes
            'iNdx = iNdx + 3
        Else
            GetMXName = sBestMX
            Exit Function
        End If
        iAnCount = iAnCount - 1
    Wend
   
    GetMXName = sBestMX
End Function

Public Function GetDNSinfo() As String
    Dim error As Long
    Dim FixedInfoSize As Long
    Dim strDNS  As String
    Dim FixedInfo As FIXED_INFO
    Dim Buffer As IP_ADDR_STRING
    Dim FixedInfoBuffer() As Byte
   
    FixedInfoSize = 0
    error = GetNetworkParams(ByVal 0&, FixedInfoSize)
    If error <> 0 Then
        If error <> ERROR_BUFFER_OVERFLOW Then
           MsgBox "GetNetworkParams sizing failed with error: " & error
           Exit Function
        End If
    End If
    ReDim FixedInfoBuffer(FixedInfoSize - 1)
   

    error = GetNetworkParams(FixedInfoBuffer(0), FixedInfoSize)
    If error = 0 Then
        CopyMemory FixedInfo, FixedInfoBuffer(0), Len(FixedInfo)
        strDNS = FixedInfo.DnsServerList.IpAddress
        strDNS = Replace(strDNS, vbCr, "")
        strDNS = Replace(strDNS, vbLf, "")
        strDNS = Replace(strDNS, vbNullChar, "")
        strDNS = Trim(strDNS)
        GetDNSinfo = strDNS
    End If
       
End Function

Private Sub Class_Initialize()
   Set objWinSock = New MSWinsockLib.Winsock
   objWinSock.Protocol = sckUDPProtocol
   objWinSock.RemotePort = 53
End Sub

Private Sub Class_Terminate()
    Set objWinSock = Nothing '
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''class
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub objWinSock_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    Debug.Print Description
End Sub

Private Sub objWinSock_DataArrival(ByVal bytesTotal As Long)
    DNSrecieved = True
    ReDim dnsReply(bytesTotal) As Byte
    objWinSock.GetData dnsReply, vbArray + vbByte
End Sub

Public Function MX_Query(DNS_Addr As String, ByVal Domain_Addr As String) As String
    Dim IpAddr As Long
    Dim iRC As Integer
    Dim dnsHead As DNS_HEADER
    Dim iSock As Integer
   
    ' 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
   
    ' Query Variables
    Dim dnsQuery() As Byte
    Dim sQName As String
    Dim dnsQueryNdx As Integer
    Dim iTemp As Integer
    Dim iNdx As Integer
    dnsQueryNdx = 0
    ReDim dnsQuery(4000)
   
    ' Setup the dns structure to send the query in
   
    ' First goes the DNS header information
    MemCopy dnsQuery(dnsQueryNdx), dnsHead, 12
    dnsQueryNdx = dnsQueryNdx + 12
   
    ' Then the domain name (as a QNAME)
    sQName = MakeQName(Domain_Addr)
    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)
    MemCopy dnsQuery(dnsQueryNdx), iTemp, Len(iTemp)
    dnsQueryNdx = dnsQueryNdx + Len(iTemp)
   
    ' The class of query (1 means INET)
    iTemp = htons(1)
    MemCopy dnsQuery(dnsQueryNdx), iTemp, Len(iTemp)
    dnsQueryNdx = dnsQueryNdx + Len(iTemp)
   
    On Error Resume Next
    ReDim Preserve dnsQuery(dnsQueryNdx - 1)
    ' Send the query to the DNS server
    objWinSock.RemoteHost = DNS_Addr
    DNSrecieved = False
    objWinSock.SendData dnsQuery
   
    If WaitUntilTrue(DNSrecieved, 60) = False Then
        'MX_Query = ""
        Exit Function
    End If
   
    Dim iAnCount As Integer
    ' Get the number of answers
    MemCopy iAnCount, dnsReply(6), 2
    iAnCount = ntohs(iAnCount)
    ' Parse the answer buffer
    MX_Query = Trim(GetMXName(dnsReply(), 12, iAnCount))
   
End Function

Private Function WaitUntilTrue(ByRef Flag As Boolean, ByVal SecondsToWait As Long) As Boolean

    Dim fStart              As Single
    Dim fTimetoQuit         As Single

    fStart = Timer

    ' Deal with timer being reset at Midnight
    If fStart + SecondsToWait < 86400 Then
        fTimetoQuit = fStart + SecondsToWait
    Else
        fTimetoQuit = (fStart - 86400) + SecondsToWait
    End If

    Do Until Flag = True
        If Timer >= fTimetoQuit Then
            WaitUntilTrue = Flag
            Exit Function
        End If
        DoEvents
        Sleep (10)   
    Loop

    WaitUntilTrue = Flag

End Function

极品源码，无限精彩，尽在 http://www.aspcdrom.com