mdns.bas

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

Attribute VB_Name = "mDNS"
Option Explicit

Private Const NS_ALL = 0
Private Const AF_INET = 2
Private Const IPPROTO_TCP = 6
Private Const IPPROTO_UDP = 17
Private Const LUP_RETURN_ALL = &HFF0
Private Const WSADESCRIPTION_LEN = 256
Private Const WSASYS_STATUS_LEN = 128
Private Const SOCK_STREAM = 1                   ' stream socket
Private Const SOCK_DGRAM = 2                    ' datagram socket
Private Const SOCK_RAW = 3                      ' raw-protocol interface
Private Const SOCK_RDM = 4                      ' reliably-delivered message
Private Const SOCK_SEQPACKET = 5                ' sequenced packet stream

Private Type GUID     '  size is 16
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type afProtocols
    iAddressFamily As Long
    iProtocol As Long
End Type

Private Type sockaddr2
    sa_family As Integer
    sa_data(13) As Byte
End Type

Private Type SOCKET_ADDRESS
    lpSockaddr As Long
    iSockaddrLength  As Long
End Type

Private Type CSADDR_INFO
    LocalAddr As SOCKET_ADDRESS
    RemoteAddr As SOCKET_ADDRESS
    iSocketType As Long
    iProtocol As Long
End Type

Private Type WSAQuerySetW
    dwSize As Long
    lpszServiceInstanceName As Long
    lpServiceClassId As Long
    lpVersion As Long
    lpszComment As Long
    dwNameSpace As Long
    lpNSProviderId As Long
    lpszContext As Long
    dwNumberOfProtocols As Long
    lpafpProtocols As Long
    lpszQueryString As Long
    dwNumberOfCsAddrs As Long
    lpcsaBuffer As Long
    dwOutputFlags As Long
    lpBlob As Long
End Type

Private Type WSADATA
    wVersion As Integer
    wHighVersion As Integer
    szDescription(WSADESCRIPTION_LEN) As Byte
    szSystemStatus(WSASYS_STATUS_LEN) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Private Declare Function WSALookupServiceBegin Lib "ws2_32.dll" Alias "WSALookupServiceBeginA" (ByVal lpqsRestrictions As Long, ByVal dwControlFlags As Long, lphLookup As Long) As Long
Private Declare Function WSALookupServiceNext Lib "ws2_32.dll" Alias "WSALookupServiceNextA" (ByVal lphLookup As Long, ByVal dwControlFlags As Long, lpdwBufferLength As Long, lpqsResults As Byte) As Long
Private Declare Function WSALookupServiceEnd Lib "ws2_32.dll" (ByVal lphLookup As Long) As Long
'Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequested As Integer, lpWSAData As WSADATA) As Long
'Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function WSAAddressToString Lib "ws2_32.dll" Alias "WSAAddressToStringA" (lpsaAddress As sockaddr, ByVal dwAddressLength As Long, ByVal lpProtocolInfo As Long, ByVal lpszAddressString As String, lpdwAddressStringLength As Long) As Long
'Private Declare Function WSAGetLastError Lib "ws2_32.dll" () As Long

 
 
Public Const DNS_RECURSION As Byte = 1

Public 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

' Registry data types
Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

' Registry access types
Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ

' Registry keys
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

' The only registry error that I care about =)
Const ERROR_SUCCESS = 0&

' Registry access functions
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long

' Variant (string array) that holds all the DNS servers found in the registry
Global sDNS As Variant
Global sMX As Variant
Global sPref As Variant ' holds the preferences
Global sBestMX As String ' Holds the "best" MX record (the one with the lowest preference)
Public ms_Domain As String
Public mi_DNSCount As Integer
Public mi_MXCount As Integer

Type IP_ADDRESS_STRING
    IpAddressString(4 * 4 - 1) As Byte
End Type
 
Type IP_MASK_STRING
    IpMaskString(4 * 4 - 1) As Byte
End Type
 
Type IP_ADDR_STRING
    Next      As Long
    IpAddress As IP_ADDRESS_STRING
    IpMask    As IP_MASK_STRING
    Context   As Long
End Type
 
Public Const MAX_HOSTNAME_LEN = 128
Public Const MAX_DOMAIN_NAME_LEN = 128
Public Const MAX_SCOPE_ID_LEN = 256
 
Type FIXED_INFO
    HostName(MAX_HOSTNAME_LEN + 4 - 1) As Byte
    DomainName(MAX_DOMAIN_NAME_LEN + 4 - 1) As Byte
    CurrentDnsServer As Long
    DnsServerList    As IP_ADDR_STRING
    NodeType         As Long
    ScopeId(MAX_SCOPE_ID_LEN + 4 - 1) As Byte
    EnableRouting    As Long
    EnableProxy      As Long
    EnableDns        As Long
End Type
 
Declare Function GetNetworkParams Lib "iphlpapi.dll" _
   (pFixedInfo As Any, _
    pOutBufLen As Long) As Long
 
Public Const ERROR_NOT_SUPPORTED = 50
Public Const ERROR_BUFFER_OVERFLOW = 111
Public Const ERROR_INVALID_PARAMETER = 87
Public Const ERROR_NO_DATA = 232
 
Declare Sub MoveMemory Lib "kernel32.dll" _
    Alias "RtlMoveMemory" _
   (Destination As Any, _
    Source As Any, _
    ByVal Length As Long)
    
' Remove the NULL character from the end of a string
Public Function StripTerminator(ByVal strString As String) As String
    Dim intZeroPos As Integer

    intZeroPos = InStr(strString, Chr$(0))
    If intZeroPos > 0 Then
        StripTerminator = Left$(strString, intZeroPos - 1)
    Else
        StripTerminator = strString
    End If
End Function

Public Sub GetDNSInfo()
    Dim hKey As Long
    Dim hError As Long
    Dim sdhcpBuffer As String
    Dim sBuffer As String
    Dim sFinalBuff As String
    Dim lngFixedInfoNeeded      As Long
    Dim bytFixedInfoBuffer()    As Byte
    Dim udtFixedInfo            As FIXED_INFO
    Dim lngIpAddrStringPtr      As Long
    Dim udtIpAddrString         As IP_ADDR_STRING
    Dim strDnsIpAddress         As String
    Dim lngWin32apiResultCode   As Long
    Dim guidServiceClass        As GUID
    Dim qs                      As WSAQuerySetW
    Dim csa()                   As CSADDR_INFO
    Dim dwFlags                 As Long
    Dim dwLen                   As Long
    Dim hLookup                 As Long
    Dim afProtocols(1)          As afProtocols
    Dim nRet                    As Long
    Dim WSVersion               As Integer
    Dim uData                   As WSADataType
    Dim bBuffer()               As Byte
    Dim lSize                   As Long
    Dim sBuffer2                As String
    Dim i                       As Integer
    Dim ptr                     As Long
    Dim remSockAddr             As sockaddr2
    Dim sText                   As String
    
    With guidServiceClass
        .Data1 = &H90035    ' last two digits are the port number(53) in hex
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    
    sdhcpBuffer = Space(1000)
    sBuffer = Space(1000)
    sDNS = vbNullString
    
    If (RegOpenKeyEx(HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\VxD\MSTCP", 0, KEY_READ, hKey) = ERROR_SUCCESS) Then
        ' DNS servers configured through Network control panel applet (95/98)
        RegQueryValueEx hKey, "NameServer", 0, REG_SZ, sBuffer, 1000
        RegCloseKey hKey
        If Trim(StripTerminator(sBuffer)) <> "" Then
            sFinalBuff = Trim(StripTerminator(sBuffer)) & ","
        End If
    End If
 
    If (RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters", 0, KEY_READ, hKey) = ERROR_SUCCESS) Then
        ' DNS servers configured through Network control panel applet (NT)
        RegQueryValueEx hKey, "NameServer", 0, REG_SZ, sBuffer, 1000
        RegCloseKey hKey
        If Trim(StripTerminator(sBuffer)) <> "" Then
            If InStr(1, sFinalBuff, Trim(StripTerminator(sBuffer))) = 0 Then
                If sFinalBuff <> "" Then
                    sFinalBuff = sFinalBuff & Trim(StripTerminator(sBuffer)) & ","
                Else
                    sFinalBuff = Trim(StripTerminator(sBuffer)) & ","
                End If
            End If
        End If
    End If
 
    If (RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters", 0, KEY_READ, hKey) = ERROR_SUCCESS) Then
        ' DNS servers configured dhcp (NT)
        RegQueryValueEx hKey, "DhcpNameServer", 0, REG_SZ, sBuffer, 1000
        RegCloseKey hKey
        If Trim(StripTerminator(sBuffer)) <> "" Then
            If InStr(1, sFinalBuff, Trim(StripTerminator(sBuffer))) = 0 Then
                If sFinalBuff <> "" Then
                    sFinalBuff = sFinalBuff & Trim(StripTerminator(sBuffer)) & ","
                Else
                    sFinalBuff = Trim(StripTerminator(sBuffer)) & ","
                End If
            End If
        End If
    End If
 
    If Is98 Or Is98se Or IsME Or Is2000 Or IsNT4 Or Is95 Or Is95B Then
        ' get dns servers with the new GetNetworkParams call
        ' only works on 98/ME/2000
        ' use the WSALookupService calls for 2000/nt4
        lngWin32apiResultCode = _
            GetNetworkParams(ByVal vbNullString, _
                             lngFixedInfoNeeded)
        If lngWin32apiResultCode = _
           ERROR_BUFFER_OVERFLOW Then
            ReDim _
                bytFixedInfoBuffer _
                   (lngFixedInfoNeeded)
        Else
            GoTo TerminateGetNetworkParams
        End If
        lngWin32apiResultCode = _
            GetNetworkParams(bytFixedInfoBuffer(0), _
                             lngFixedInfoNeeded)
        MoveMemory _
            udtFixedInfo, _
            bytFixedInfoBuffer(0), _
            Len(udtFixedInfo)
        With udtFixedInfo
            lngIpAddrStringPtr = _
                VarPtr(.DnsServerList)
            Do While lngIpAddrStringPtr
                MoveMemory _
                    udtIpAddrString, _
                    ByVal lngIpAddrStringPtr, _
                    Len(udtIpAddrString)
                With udtIpAddrString
                    strDnsIpAddress = _
                        StrConv(.IpAddress _
                                    .IpAddressString, _
                                vbUnicode)
                    If sFinalBuff = vbNullString Then
                        sFinalBuff = Left(strDnsIpAddress, InStr(strDnsIpAddress, vbNullChar) - 1) & ","
                    Else
                        If InStr(1, sFinalBuff, Left(strDnsIpAddress, InStr(strDnsIpAddress, vbNullChar) - 1) & ",") = 0 Then
                            sFinalBuff = sFinalBuff & Left(strDnsIpAddress, InStr(strDnsIpAddress, vbNullChar) - 1) & ","
                        End If
                    End If
                    lngIpAddrStringPtr = .Next
                End With