The source code is foreigner, and I made some changes, I wrote a DLL.
method:
Public function getDnsInfo () AS STRING
Get DNS information
Public Function MX_QUERY (DNS_ADDR AS STRING, BYVAL DOMAIN_ADDR AS STRING) AS STRING
Get the best record of MX,
DNS_ADDR, domain name resolution server, can be obtained with getDnsInfo, or use nslookup command
Domain_addr, you want to get the domain name of the mail server, such as 163.com, hotmail.com
http://www.56city.net
VERSION 1.0 CLASSBEGIN MultiUse = -1 'True Persistable = 0' NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0' vbNone MTSTransactionMode = 0 'NotAnMTSObjectENDAttribute VB_Name = "mxquery" Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = TrueAttribute VB_PredeclaredId = FalseAttribute VB_Exposed = TrueOption Explicit
Private Withemock Objwinsock As MswinsockLib.winsockAttribute Objwinsock.vb_varhelpid = -1
PRIVATE const error_buffer_overflow = 111
Private dnsrecieved as booleanprivate dnsreply () as Byte
Private Declare Function GetNetworkParams Lib "IPHlpApi" (FixedInfo As Any, pOutBufLen As Long) As LongPrivate 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 IntegerPrivate Declare Function ntohs Lib "wsock32.dll "(Byval Netshort As Long) AS Integer
Private Declare Sub Sleep Lib "Kernel32" (Byval dwmilliseconds as ring)
Private Const DNS_RECURSION As Byte = 1Private Const MAX_HOSTNAME_LEN = 132Private Const MAX_DOMAIN_NAME_LEN = 132Private Const MAX_SCOPE_ID_LEN = 260Private Const MAX_ADAPTER_NAME_LENGTH = 260Private Const MAX_ADAPTER_ADDRESS_LENGTH = 8Private Const MAX_ADAPTER_DESCRIPTION_LENGTH = 132Private Type IP_ADDR_STRING Next As Long IpAddress As String * 16 IpMask As String * 16 Context As LongEnd 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 LongEnd 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 INTEGEREND TYPE
PRIVATE TYY HOSTENT H_NAME AS LONG H_AASES AS Long H_addrtype as integer h_length as integer h_addr_list as longend Type
Private const hostent_size = 16
PRIVATE TYPE SERVENT S_NAME AS Long S_Aliases As Long S_Port As INTEGER S_PROTO AS LONGEND 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, The Putur Character Count and the Part of The Stringiff (Schar = ") THEN SQNAME = SQNAME & CHR (iqcount) & sdotname qcount = 0 sdotname = "" Else SDOTNAME = SDOTNAME SCHAR IQCOUNT = IQCOUNT 1 END IF INDX = INDX 1 Wend Sqname = SQNAME & CHR (i QCount) & sDotName MakeQName = sQNameEnd FunctionPrivate 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 did not 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 (Indox) <> 0) THEN SNAME = SNAME "." Wendend 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 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 classock = new mswinsocklib.winsock objwinsock.protocol = SCKUDPPROTOCOL OBJWINSOCK.REMOTEPORT = 53nd Sub Private sub class_terminate () set objwinsock = Nothing 'End Sub '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' ' '' '' '' '' '' '' '' '' '' '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 DescriptionEnd SubPrivate Sub objWinSock_DataArrival (ByVal bytesTotal As Long) DNSrecieved = True ReDim dnsReply (bytesTotal) As Byte objWinSock.GetData dnsReply, vbArray vbByteEnd 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 (Indox 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 FunctionPrivat E 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 Endix Do Until Flag = true if Timer> = fTimetoquit Then Waituntiltrue = flag exit function end if dolents sleep (10) loop WAITUNTILTRUE = Flag END FUNCTION
