VB and VBA Users Source Code: Enumerate the trusted domains on a server
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Enumerate the trusted domains on a server
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Friday, January 26, 2001
Hits:
549
Category:
Networks
Article:
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. 'Author : Andrew Baker 'Date : 26/01/2001 10:29 'Notes : 'Revisions : 'Assumptions : 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 'Author : Andrew Baker 'Date : 03/08/2000 19:14 'Notes : 'Revisions : 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
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
