modmxquery.bas

简单、实用、特别。 有很多不足之处

        MX_Query = GetMXName(dnsReply(), 12, iAnCount)
        
    Else
        ' if we didn't find anything and we are part of
        ' a sub domain, go up one level and try again
        ' the last pass is at the root domain level
        If InStr(MX.Domain, DNS.RootDomain) > 1 Then
            MX.Domain = Mid$(MX.Domain, InStr(MX.Domain, ".") + 1)
            MX_Query = MX_Query(MX.Domain)
        End If
    End If
    
End Function

Private Sub ParseName(dnsReply() As Byte, iNdx As Integer, sName As String)
    
' 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.
    
    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

Private Function GetMXName(dnsReply() As Byte, iNdx As Integer, iAnCount As Integer) As String
    
' 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)
    
    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
    
    
    MX.Count = 0
    MX.Best = vbNullString
    ReDim MX.List(0)

    iMXCount = 0
    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
    
    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
            
            CopyMemory 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 MX.List(iMXCount - 1)
                MX.List(iMXCount - 1).Server = sName
                MX.List(iMXCount - 1).Pref = iPref
                MX.Count = iMXCount
                If (iBestPref = -1 Or iPref < iBestPref) Then
                    iBestPref = iPref
                    MX.Best = sName
                End If
            End If
            ' Step over 3 useless bytes
            iNdx = iNdx + 3
        Else
            GetMXName = MX.Best
            SortMX MX.List
            Exit Function
        End If
        iAnCount = iAnCount - 1
    Wend
    
    SortMX MX.List
        
    GetMXName = MX.Best

End Function

Private Function MakeQName(sDomain As String) As String
    
' Takes sDomain and converts it to the QNAME-type string.
' QNAME is how a DNS server expects the string.
'
' Example:  Pass -        mail.com
'           Returns -     &H4mail&H3com
'                          ^      ^
'                          |______|____ These two are character counters, they count
'                                       the number of characters appearing after them
    
    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 Function GetHostByNameAlias(ByVal sHostName As String) As Long
    
    'Return IP address as a long, in network byte order
    
    Dim phe             As Long
    Dim heDestHost      As HostEnt
    Dim addrList        As Long
    Dim retIP           As Long
    
    retIP = inet_addr(sHostName)
    
    If retIP = INADDR_NONE Then
        phe = gethostbyname(sHostName)
        If phe <> 0 Then
            CopyMemory heDestHost, ByVal phe, LenB(heDestHost)
            CopyMemory addrList, ByVal heDestHost.h_addr_list, 4
            CopyMemory retIP, ByVal addrList, heDestHost.h_length
        Else
            retIP = INADDR_NONE
        End If
    End If
    
    GetHostByNameAlias = retIP
    
End Function

Private Function StripTerminator(ByVal strString As String) As String
    
    ' strip off trailing NULL's from API calls
    
    Dim intZeroPos      As Integer

    intZeroPos = InStr(strString, vbNullChar)
    
    If intZeroPos > 1 Then
        StripTerminator = Trim$(Left$(strString, intZeroPos - 1))
    ElseIf intZeroPos = 1 Then
        StripTerminator = vbNullString
    Else
        StripTerminator = strString
    End If
    
End Function

Private Function GetRegStr(hKeyRoot As Long, ByVal sKeyName As String, ByVal sValueName As String, Optional ByVal Default As String = "") As String
   
   Dim lRet             As Long
   Dim hKey             As Long
   Dim lType            As Long
   Dim lBytes           As Long
   Dim sBuff            As String
   
   ' in case there's a permissions violation
   On Local Error GoTo Err_Reg

   ' Assume failure and set return to Default
   GetRegStr = Default

   ' Open the key
   lRet = RegOpenKeyEx(hKeyRoot, sKeyName, 0&, KEY_READ, hKey)
   If lRet = ERROR_SUCCESS Then
      
      ' Determine the buffer size
      lRet = RegQueryValueEx(hKey, sValueName, 0&, lType, ByVal sBuff, lBytes)
      If lRet = ERROR_SUCCESS Then
         ' size the buffer & call again
         If lBytes > 0 Then
            sBuff = Space(lBytes)
            lRet = RegQueryValueEx(hKey, sValueName, 0&, lType, ByVal sBuff, Len(sBuff))
            If lRet = ERROR_SUCCESS Then
               ' Trim NULL and return
               GetRegStr = Left(sBuff, lBytes - 1)
            End If
         End If
      End If
      Call RegCloseKey(hKey)
   End If
   
   Exit Function
   
Err_Reg:

  If hKey Then Call RegCloseKey(hKey)
   
End Function

Private Function EnumRegKey(hKeyRoot As Long, sKeyName As String) As String()
    

    Dim lRet            As Long
    Dim ft              As FILETIME
    Dim hKey            As Long
    Dim CurIdx          As Long
    Dim KeyName         As String
    Dim ClassName       As String
    Dim KeyLen          As Long
    Dim ClassLen        As Long
    Dim RESERVED        As Long
    Dim sEnum()         As String
    
    On Local Error GoTo Err_Enum
    
    ' initialize array
    EnumRegKey = Split("", "")
    
    ' Open the key
    lRet = RegOpenKeyEx(hKeyRoot, sKeyName, 0&, KEY_READ, hKey)
    If lRet <> ERROR_SUCCESS Then Exit Function
    
    ' the key opened so get all the sub keys
    Do
        ' get each sub key until lRet = error
        KeyLen = 2000
        ClassLen = 2000
        KeyName = String$(KeyLen, 0)
        ClassName = String$(ClassLen, 0)
        lRet = RegEnumKeyEx(hKey, CurIdx, KeyName, KeyLen, RESERVED, ClassName, ClassLen, ft)

        If lRet = ERROR_SUCCESS Then
            ReDim Preserve sEnum(CurIdx)
            sEnum(CurIdx) = Left$(KeyName, KeyLen)
        End If
    
        CurIdx = CurIdx + 1
        
    Loop While lRet = ERROR_SUCCESS
      
Err_Enum:

    EnumRegKey = sEnum
    If hKey Then Call RegCloseKey(hKey)

End Function

Private Function Exported(ByVal ModuleName As String, ByVal ProcName As String) As Boolean
   
    ' see if the api supports a call
    
    Dim hModule         As Long
    Dim lpProc          As Long
    Dim FreeLib         As Boolean
   
    ' check to see if the module is already
    ' mapped into this process.
    hModule = GetModuleHandle(ModuleName)
    If hModule = 0 Then
        ' not mapped, load the module into this process.
        hModule = LoadLibrary(ModuleName)
        FreeLib = True
    End If
   
    ' check the procedure address to verify it's exported.
    If hModule Then
        lpProc = GetProcAddress(hModule, ProcName)
        Exported = (lpProc <> 0)
    End If
   
    ' unload library if we loaded it here.
    If FreeLib Then Call FreeLibrary(hModule)
    
End Function

Private Sub SortMX(arr() As MX_RECORD, Optional ByVal bSortDesc As Boolean = False)

    ' simple bubble sort

    Dim ValMX           As MX_RECORD
    Dim index           As Long
    Dim firstItem       As Long
    Dim indexLimit      As Long
    Dim lastSwap        As Long

    firstItem = LBound(arr)
    lastSwap = UBound(arr)
    
    Do
        indexLimit = lastSwap - 1
        lastSwap = 0
        For index = firstItem To indexLimit
            ValMX.Pref = arr(index).Pref
            ValMX.Server = arr(index).Server
            If (ValMX.Pref > arr(index + 1).Pref) Xor bSortDesc Then
                ' if the items are not in order, swap them
                arr(index).Pref = arr(index + 1).Pref
                arr(index).Server = arr(index + 1).Server
                arr(index + 1).Pref = ValMX.Pref
                arr(index + 1).Server = ValMX.Server
                lastSwap = index
            End If
        Next
    Loop While lastSwap

End Sub

Private Function GetRemoteHostName(ByVal strIpAddress As String) As String

    Dim udtHostEnt      As HostEnt  ' HOSTENT structure
    Dim lngPtrHostEnt   As Long     ' pointer to HOSTENT
    Dim lngInetAddr     As Long     ' address as a Long value
    Dim strHostName     As String   ' string buffer for host name

    ' initialize the buffer
    strHostName = String(256, 0)

    ' Convert IP address to Long
    lngInetAddr = inet_addr(strIpAddress)
    If lngInetAddr = INADDR_NONE Then Exit Function
        
    ' Get the HostEnt structure pointer
    lngPtrHostEnt = gethostbyaddr(lngInetAddr, 4, AF_INET)
    If lngPtrHostEnt = 0 Then Exit Function
            
    ' Copy data into the HostEnt structure
    CopyMemory udtHostEnt, ByVal lngPtrHostEnt, LenB(udtHostEnt)
    CopyMemory ByVal strHostName, ByVal udtHostEnt.h_name, Len(strHostName)

    GetRemoteHostName = StripTerminator(strHostName)

End Function