VB学习:MX记录获取组件

  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