mdns.bas

邮件发送类程序,需要smtp验证,欢迎大家测试.

            Loop
        End With
    
         ' WSALookupService calls
        qs.dwSize = Len(qs)
        qs.lpszServiceInstanceName = 0
        qs.lpServiceClassId = VarPtr(guidServiceClass.Data1)
        qs.dwNameSpace = NS_ALL
        qs.dwNumberOfProtocols = 2
        qs.lpafpProtocols = afProtocols(0).iAddressFamily
    
        afProtocols(0).iAddressFamily = AF_INET
        afProtocols(0).iProtocol = IPPROTO_TCP
        afProtocols(1).iAddressFamily = AF_INET
        afProtocols(1).iProtocol = IPPROTO_UDP
    
        dwFlags = LUP_RETURN_ALL
        WSVersion = &H202   ' just assume we can handle up to winsock version 2.2
    
        nRet = WSAStartup(WSVersion, uData)
        If nRet = 0 Then
            nRet = WSALookupServiceBegin(VarPtr(qs.dwSize), dwFlags, hLookup)
            If nRet = 0 Then
                lSize = 2048
                ReDim bBuffer(lSize - 1)
                
                While WSALookupServiceNext(hLookup, dwFlags, lSize, bBuffer(0)) = 0
                    Call CopyMemory(qs.dwSize, bBuffer(0), Len(qs))
                    ReDim csa(qs.dwNumberOfCsAddrs - 1)
                    For i = 0 To qs.dwNumberOfCsAddrs - 1
                        ptr = qs.lpcsaBuffer + (i * Len(csa(i)))
                        Call CopyMemory(csa(i).LocalAddr, ByVal ptr, Len(csa(i)))
                        Call CopyMemory(remSockAddr.sa_family, ByVal csa(i).RemoteAddr.lpSockaddr, Len(remSockAddr))
                        sText = remSockAddr.sa_data(2) & "." & remSockAddr.sa_data(3) & "." & remSockAddr.sa_data(4) & "." & remSockAddr.sa_data(5)
                        If sFinalBuff = vbNullString Then
                            sFinalBuff = sText & ","
                        Else
                            sFinalBuff = sFinalBuff & sText & ","
                        End If
                    Next
                    lSize = 2048
                    ReDim bBuffer(lSize - 1)
                Wend
                nRet = WSALookupServiceEnd(hLookup)
            Else
                nRet = WSAGetLastError
' this will error out every time on win98/98se.
' seems the call's parameters have changed. with no documentation of the change.
'                MsgBox "Socket Error : " & nRet
            End If

        End If
        nRet = WSACleanup
    
    End If
    
    If Is95 Or Is95B Then
        ' get dns servers the old way
        ' anyone wanna tell me how to do this?
        
    End If
 
    If Right(sFinalBuff, 1) = "," Then sFinalBuff = Left(sFinalBuff, Len(sFinalBuff) - 1)
     
    sDNS = Split(sFinalBuff, ",")
    
    mi_DNSCount = UBound(sDNS)
    
TerminateGetNetworkParams:
    
End Sub

' Parse the server name out of the MX record, returns it in variable sName, iNdx is also
' modified to point to the end of the parsed structure.
Private Sub ParseName(dnsReply() As Byte, iNdx As Integer, sName As String)
    Dim iCompress As Integer        ' Compression index (index to original buffer)
    Dim iChCount As Integer         ' Character count (number of chars to read from buffer)
        
    ' While we dont 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

' Parses the buffer returned by the DNS server, returns the best MX server (lowest preference
' number), iNdx is modified to point to the current buffer position (should be the end of the buffer
' by the end, unless a record other than MX is found)
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 the original query string
    
    Dim iBestPref As Integer    ' Holds the "best" preference number (lowest)
    Dim iMXCount As Integer
    ReDim sMX(0) As Variant
    ReDim sPref(0) As Variant
    iMXCount = 0
    iBestPref = -1
    sBestMX = vbNullString
    
    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
    
    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
            
            ' 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)
            ParseName dnsReply(), iNdx, sName
            
            If Trim(sName) <> "" Then
                iMXCount = iMXCount + 1
                ReDim Preserve sMX(iMXCount - 1) As Variant
                ReDim Preserve sPref(iMXCount - 1) As Variant
                sMX(iMXCount - 1) = sName
                sPref(iMXCount - 1) = iPref
                mi_MXCount = iMXCount - 1
                If (iBestPref = -1 Or iPref < iBestPref) Then
                    iBestPref = iPref
                    sBestMX = sName
                End If
            End If
            ' Step over 3 useless bytes
            iNdx = iNdx + 3
        Else
            GetMXName = sBestMX
            Exit Function
        End If
        iAnCount = iAnCount - 1
    Wend
    
    GetMXName = sBestMX
End Function

' Takes sDomain and converts it to the QNAME-type string, returns that. QNAME is how a
' DNS server expects the string.
'
'    Ex...    Pass -        mail.com
'             Returns -     &H4mail&H3com
'                            ^      ^
'                            |______|____ These two are character counters, they count the
'                                         number of characters appearing after them
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

' Performs the actual IP work to contact the DNS server, calls the other functions to parse
' and return the best server to send email through
Public Function MX_Query() As String
    Dim StartupData As WSADataType
    Dim SocketBuffer As sockaddr
    Dim IpAddr As Long
    Dim iRC As Integer
    Dim dnsHead As DNS_HEADER
    Dim iSock As Integer
    Dim dnsQuery() As Byte
    Dim sQName As String
    Dim dnsQueryNdx As Integer
    Dim iTemp As Integer
    Dim iNdx As Integer
    Dim dnsReply(2048) As Byte
    Dim iAnCount As Integer

    ' check for properties being set
    ''
    If Len(ms_Domain) < 5 Then
        Err.Raise 0, "MXQuery", "No Valid Domain Specified"
        Exit Function
    End If
    ''
    
    ' Initialize the Winsocket
    iRC = WSAStartup(&H101, StartupData)
    iRC = WSAStartup(&H101, StartupData)
    If iRC = SOCKET_ERROR Then Exit Function
    
    
    ' Create a socket
    iSock = socket(AF_INET, SOCK_DGRAM, 0)
    If iSock = SOCKET_ERROR Then Exit Function
    
    GetDNSInfo
    
    ' check to see that we found a dns server
    If UBound(sDNS) = 0 Then
        ' problem
        Err.Raise 0, "MX_Query", "No DNS Entries found. Cannont complete MX Lookup."
        Exit Function
    End If
    
    IpAddr = GetHostByNameAlias(sDNS(0))
    If IpAddr = -1 Then Exit Function
    
    ' get dns info
    
    ' Setup the connnection parameters
    SocketBuffer.sin_family = AF_INET
    SocketBuffer.sin_port = htons(53)
    SocketBuffer.sin_addr = IpAddr
    SocketBuffer.sin_zero = String$(8, 0)
    
    ' 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
    
    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(ms_Domain)
    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)
    
    ReDim Preserve dnsQuery(dnsQueryNdx - 1)
    ' Send the query to the DNS server
    iRC = sendto(iSock, dnsQuery(0), dnsQueryNdx + 1, 0, SocketBuffer, Len(SocketBuffer))
    If (iRC = SOCKET_ERROR) Then
        MsgBox "Problem sending"
        Exit Function
    End If
    
    ' Wait for answer from the DNS server
    iRC = recvfrom(iSock, dnsReply(0), 2048, 0, SocketBuffer, Len(SocketBuffer))
    If (iRC = SOCKET_ERROR) Then
        MsgBox "Problem receiving"
        Exit Function
    End If
    
    ' Get the number of answers
    MemCopy iAnCount, dnsReply(6), 2
    iAnCount = ntohs(iAnCount)
    ' Parse the answer buffer
    MX_Query = GetMXName(dnsReply(), 12, iAnCount)
    
End Function