MX記錄獲取元件（vb實現） (轉)

MX記錄獲取元件（vb實現） (轉)[@more@]

原始碼是老外的，俺做了點修改，寫成了dll

方法：

Public Function Getinfo() As String

獲取dns資訊

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

獲取mx最佳記錄，

dns_addr,域名解析，可以用getdnsinfo獲取，也可以用nslookup命令

domain_addr，想要獲取伺服器的域名，如163.,hot.com

cdrom.com/down/mxquery.rar">

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTS
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 GeworkParams Lib "IPHlp" (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_PE_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
  Enable 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 ste 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_Tenate()
  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)
  De.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)
  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) 
  L

  WaitUntilTrue = Flag

End Function

極品原始碼，無限精彩，盡在