Visual Basic Programming Code Examples

Visual Basic > Internet Web Mail Stuff Code Examples

Enumerate the trusted domains on a server



Enumerate the trusted domains on a server

To enumerate the domains on a server use the following routine:

Option Explicit

Private Declare Function NetEnumerateTrustedDomains Lib "Netapi32.dll" (yServerName As Byte, DomainNames As Long) As Long
Private Declare Function NetApiBufferFree Lib "Netapi32.dll" (ByVal lpBuffer As Long) As Long
Private Declare Function StrToPtr Lib "kernel32" Alias "lstrcpyW" (ByVal Ptr As Long, Source As Byte) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long

'Purpose     :  Enumerate the domain names of a given server
'Inputs      :  asDomainList                See outputs
'               [sServerName]               The name of the server to enumerate the domain names on.
'                                           If not specified defaults to local machine.
'Outputs     :  asDomainList                A string array (1 to NumDomains).
'               Returns                     The number of domains found on success or
'                                           -1 on failure.


Public Function DomainsEnum(ByRef asDomainList() As String, Optional ByVal sServerName As String) As Long
    Dim abServerName() As Byte, lpDomains As Long, lRetVal As Long
    Dim abBuffer() As Byte
    Dim sDomain As String
    Dim lptrPos As Long, lLen As Long
    Dim iNumVBNullCharsFound As Integer
    On Error GoTo ErrFailed
    If Len(sServerName) Then
        'Format the server name
        If Left$(sServerName, 2) <> "\\" Then
            sServerName = "\\" & sServerName
        End If
    End If
    If Right$(sServerName, 1) <> vbNullChar Then
        sServerName = sServerName & vbNullChar
    End If
    abServerName = sServerName
    lRetVal = NetEnumerateTrustedDomains(abServerName(0), lpDomains)
    
    If lpDomains Then
        ReDim asDomainList(1 To 1)
        'Move along memory, copy domain names into array,
        'until an empty string is returned
        Do
            sDomain = StrFromPtr(lpDomains + lptrPos)
            If Len(sDomain) Then
                DomainsEnum = DomainsEnum + 1
                ReDim Preserve asDomainList(1 To DomainsEnum)
                asDomainList(DomainsEnum) = sDomain
            Else
                Exit Do
            End If
            'Move the pointer along
            lptrPos = lptrPos + LenB(sDomain) + 2
        Loop
    Else
        Erase asDomainList
    End If
    'Free Memory
    lRetVal = NetApiBufferFree(lpDomains)
    Exit Function
ErrFailed:
    'Error occurred
    DomainsEnum = -1
End Function

'Purpose     :  Converts a pointer to a string into a string.
'Inputs      :  lPtr            A long pointer to a string held in memory
'Outputs     :  The string held at the specified memory address


Private Function StrFromPtr(ByVal lPtr As Long) As String
    Dim lLen As Long
    Dim abytBuf() As Byte

    'Get the length of the string at the memory location
    lLen = lstrlenW(lPtr) * 2 - 1   'Unicode string (must double the buffer size)
    
    If lLen > 0 Then
        ReDim abytBuf(lLen)
        'Copy the memory contents
        'into a they byte buffer
        Call CopyMem(abytBuf(0), ByVal lPtr, lLen)
        'convert and return the buffer
        StrFromPtr = abytBuf
    End If
End Function

'Demonstration routine
Sub Test()
    Dim asDomainNames() As String
    Dim lThisDomain As Long, lNumDomains As Long
    
    lNumDomains = DomainsEnum(asDomainNames())

    For lThisDomain = 1 To lNumDomains
        Debug.Print asDomainNames(lThisDomain)
    Next
End Sub