MX记录获取组件(vb实现)

转载 2004年10月28日 17:44:00

源码是老外的,俺做了点修改,写成了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


VB用API获取本机IP地址

Option Explicit Public Const MIN_SOCKETS_REQD As Long = 1 Public Const WS_VERSION_REQD As Long = &H...
  • laotou99
  • laotou99
  • 2012年12月26日 15:32
  • 4496

MX记录获取组件(vb实现)

源码是老外的,俺做了点修改,写成了dll方法:Public Function GetDNSinfo() As String获取dns信息Public Function MX_Query(DNS_Add...
  • glling
  • glling
  • 2004年02月02日 23:30
  • 853

MX记录获取组件的编写

一、MX记录的应用         Email是迄今为止互联网上最成功的应用了,试想一个触网者如果没有属于自己的Email邮箱,那将难以称作“网民”。互联网网上同Email相关的应用也增多。我们编写网...
  • shanhe
  • shanhe
  • 2003年03月07日 08:43
  • 1993

如何利用nslookup命令查询mx记录?以及邮件相关记录

Nslookup 是一个监测网络中DNS服务器是否能正确实现域名解析的命令行工具。它在 Windows NT/2000/XP 中均可使用。 本文主要是针对邮箱的mx记录以及相关的查询方法做一些参考:...
  • dickens88
  • dickens88
  • 2012年10月20日 16:25
  • 23744

MX记录及MX记录优先级

MX记录及MX记录优先级MX  MX(Mail Exchanger)记录  是邮件交换记录,它指向一个邮件服务器,用于电子邮件系统发邮件时根据 收信人的地址后缀来定位邮件服务器。例如,当Interne...
  • vince6799
  • vince6799
  • 2008年11月26日 14:40
  • 25540

搭建邮件服务器时设置A/MX记录方法详解

转:http://blog.sina.com.cn/s/blog_9c7800590101bgm8.html   域名解析是在域名管理注册的后来操作的,常见的域名注册商有万网、新网、花生壳等。设置...
  • pzasdq
  • pzasdq
  • 2016年04月17日 01:10
  • 8021

如何查看MX记录是否已经生效?

创建注册域名特色功能登录和退出写信和发信收信和删信退信外域入信失败原因反垃圾邮件防病毒管理其他邮箱客户端设置邮箱记事本文件中转站更新日记手机邮箱Exchange同步服务Outlook助手反垃圾云平台邮...
  • bugDemo
  • bugDemo
  • 2013年08月27日 10:27
  • 1040

dig查询MX记录

指定DNS dig @8.8.8.8 mx 域名
  • lovejunelove
  • lovejunelove
  • 2014年04月09日 17:58
  • 2043

检查MX记录

进行DNS查询的一个非常有用的工具是nslookup,可以使用它来查询DNS中的各种数据。可以在Windows的命令行下直接运行nslookup进入一个交互模式,在这里能查询各种类型的DNS数据。 ...
  • zhaodm
  • zhaodm
  • 2011年01月18日 10:31
  • 5043

关于邮件服务器的dns解析及mx记录问题!

如何做域名的MX解析记录? -------------------------------------------------------------------------------- 大多数...
  • vebasan
  • vebasan
  • 2015年01月02日 00:48
  • 4702
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:MX记录获取组件(vb实现)
举报原因:
原因补充:

(最多只允许输入30个字)