finding a user in active directory using vba

[Hackepeter]

Hi Folks,

I've tried various searches in this and other forums. Nothing helped me out with my problem. So I'm asking YOU .
I use Excel 2007.

the background:
we have a bigger AD with more than only one hirarchical level in ad.
I need to find a user with a given "sAMAccountName".
I don't know where his entry is located in the tree.
as example my user's path is:
OU=06,OU=Users,DC=domain,DC=com

others are located in other groups in group "Users". There are about 90 subgroups in this section.

What I can do ist to walk down in 2 loops from root through every object in these groups. But this can´t be the solution.

What I want is to "search" the AD and find the correct entry and it's path.
something like
search "me" in AD
returning the object "me" for accessing the needed parameters (me.name...) or me.member (which is another task why I want to have this code as generic as possible)

What I have now:

Sub test()   ' will be a function later on if working

Dim colOU As IADsContainer
Dim strName as String    ' --> I use a fixed value of the sAMAccountName for testing this
Dim sAUFRUF As String


strName = "userid"
    sAUFRUF = "LDAP://DC=domain, DC=com, sAMAccountName=" & strName


Set colOU = GetObject(sAUFRUF)  ' --> :crash:


    Debug.Print colOU.Name
    Debug.Print colOU.AccountExpirationDate

I will get an Error -2147016672 saying somthing crytic.

There must be a mistake in syntaxing the value of sAUFRUF. I'm german...

Can you hepl me?

thanks

 

[jimrward]

i had a play with AD last year, try the following on your machine, and change end of the line Ward Jim, to a known user in your AD and see what happens

strFilter = "(&(objectCategory=person)(objectClass=user)(cn=Ward Jim*))"

Dim gl As Integer
Dim pl As Integer
Dim cl As Integer
Dim fl As Integer
Sub LDAPGetAllUserInfoFromAD()
'****
' Query interogate AD/LDAP for a given user and report
'
'
' Author    Jim Ward
' Creation  30th June 2011
'
' Gleaned from various sources and assembled into the following
'
'****
'
'****
' and now the worksheet names and column headings, and AD attribute to report
'****
'

Dim ListName1 As String
ListName1 = "UserInfo" & "_" & Format(Now(), "yyyymmdd")

Dim strFilter As String

'
'****
' all declarations done lets begin
'****
'
'
'****
' Turn off updates and calculations
'****
'

'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = True
Application.StatusBar = "Searching for Records..."

'
'****
' found something so create the output files and write the headers
'****
'

Application.StatusBar = "Creating Worksheet headers..."

'
'****
' delete any old versions of the sheets if they exist, saves on close, file new etc
'****
'

Application.DisplayAlerts = False
On Error Resume Next
Sheets(ListName1).Delete
Application.DisplayAlerts = True
On Error GoTo 0

'
'****
' by default my excel opens showing 3 unused sheets, so add our sheets
'****
'
    
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = ListName1
Set objsheet = Worksheets(ListName1)
objsheet.Cells(1, 1) = "Group Name"
objsheet.Cells(1, 1).Font.Bold = True

Set objsheet = Worksheets("Folder")
objsheet.Cells(1, 1) = "Group Name"
objsheet.Cells(1, 1).Font.Bold = True

'
'****
' Filter on user objects.
'****
' all users
strFilter = "(&(objectCategory=person)(objectClass=user)(cn=Ward Jim*))"
Call SearchAndExtract2(strFilter, ListName1, "A1")

'
'****
' Turn ON updates and calculations, lose status bar
'****
'

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
MsgBox "All Done"

End Sub
Sub SearchAndExtract2(strFilter As String, wsName As String, SortByCol As String)

Const xlAscending = 1
Const xlDescending = 2
Const xlYes = 1

Dim OkToGo As Boolean

Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection

'
'****
' Search entire Active Directory domain.
'****
'

Set objRootDSE = GetObject("LDAP://RootDSE")
'Stop
strDNSDomain = objRootDSE.Get("defaultNamingContext")
strBase = "<LDAP://" & strDNSDomain & ">"

'
'****
' Construct the LDAP query.
'****
'
strAttributes = "sAMAccountName,memberof"
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

'
'****
' Run the query, and get our recordset
'****
'

Set adoRecordset = adoCommand.Execute

cl = 1      'count lines
gl = 1
pl = 1
fl = 1

Application.StatusBar = "Populating Worksheets..."
Set objsheet = Worksheets(wsName)

Do Until adoRecordset.EOF
    arrGroups = adoRecordset.Fields("memberOf").Value
    If IsNull(arrGroups) Then
        gl = gl + 1
        objsheet.Cells(gl, 0).Value = "-- No group memberships"
    Else
        For Each StrGroup In arrGroups
            i = InStr(StrGroup, ",")
            StrGroup = Mid(StrGroup, 4, i - 4)
            If Right(StrGroup, 3) = "_RW" Or Right(StrGroup, 3) = "_RO" Then
                fl = fl + 1
                Set objsheet = Worksheets("Folder")
                tl = fl
            Else
                cl = cl + 1
                Set objsheet = Worksheets(wsName)
                tl = cl
            End If
            i = InStr(StrGroup, ",")
            objsheet.Cells(tl, 1).Value = StrGroup
        Next
    End If
    adoRecordset.MoveNext
Loop

'
'****
' All done, name sheet, sort data, autofit columns, close up and exit
'****
'
'
'****
' to sort the data we have to actually select the required sheet before we can do anything
'****
'

Set objworksheet = Worksheets(wsName)
objworksheet.Select
Set objrange = objworksheet.UsedRange
Set objrange2 = Range(SortByCol)
objrange.Sort objrange2, xlAscending, , , , , , xlYes

ActiveSheet.UsedRange.Columns.EntireColumn.AutoFit

'
'****
' Clean up
'****
'

adoRecordset.Close
adoConnection.Close

Set adoRecordset = Nothing
Set objrange = Nothing
Set objrange2 = Nothing
Set objworksheet = Nothing

End Sub

 

[Hackepeter]

Thank you. But this isn't what I want. I found similar suggestions to realize that with ADO-connections.

I don't want to use ADO. What I need is the syntax description of using:

something = GetObject(".....")

inside this getobjekt-string there should be a possibility to set a "search pattern" and some search parameters like "tree-depth" to proceed.

If I know the position of the object I can read it.
But I want to read it if I don't know the exact position of this in the AD-tree.

Any hints how to solve this?

thanks peter

 

[quarencia]

Looks like your code was cut off. This is pretty old, but if you still have this, any chance you could post all of this code?

 

[jimrward]

Try scrolling the code box it's all there

 

[Air_Cooled_Nut]

Try scrolling the code box it's all there

I'm logged in to the forum and it's not. These are the last four lines of code I see:

Set objRootDSE = GetObject("LDAP://RootDSE")
'Stop
strDNSDomain = objRootDSE.Get("defaultNamingContext")
strBase = "

 

[Jack in the UK]

Your AD is complex, sounds like tooooo much forest
The IT guys need to get on top of this, VBA can do the basics

You know the user?
To manage their AD and structure and see their groups, right?

VBA is not the tool for this M$ Windows is via Admin

 

[Jack in the UK]

Play this ...

Option Explicit

Enum COMPUTER_NAME_FORMAT
    ComputerNameNetBIOS
    ComputerNameDnsHostname
    ComputerNameDnsDomain
    ComputerNameDnsFullyQualified
    ComputerNamePhysicalNetBIOS
    ComputerNamePhysicalDnsHostname
    ComputerNamePhysicalDnsDomain
    ComputerNamePhysicalDnsFullyQualified
End Enum

Declare Function GetComputerNameEx Lib "kernel32" Alias "GetComputerNameExA" ( _
ByVal NameType As COMPUTER_NAME_FORMAT, _
ByVal lpBuffer As String, _
ByRef lpnSize As Long) As Long

Sub test()

Dim buffer As String
Dim size As Long
Dim network_and_computer As String
Dim network_name As String

size = 255
buffer = Space(size)
GetComputerNameEx ComputerNameDnsFullyQualified, buffer, size
network_and_computer = Left$(buffer, size)

MsgBox network_and_computer

network_name = Right(network_and_computer, Len(network_and_computer) - InStr(1, network_and_computer, ".", vbTextCompare))

MsgBox network_name

End Sub

 

[Air_Cooled_Nut]

Not being an AD person I have no idea what "forest" and "trees" is all about but this worked. Here's something I cobbled together from a few different sources and it works for me when searching for a person:

Option Explicit

Sub Main()
    Call AD_Get_Info("Toby", "Erkson")
End Sub

Function AD_Get_Info(ByVal sFirst As String, sLast As String) As Variant
'Get specific AD/LDAP user info for a given first and last name.

Dim oCmd As Object, oConn As Object, oRecSet As Object, objField As Object

'Set up ADO query and excute to find group matches
Set oCmd = CreateObject("ADODB.Command")
Set oConn = CreateObject("ADODB.Connection")
Set oRecSet = CreateObject("ADODB.Recordset")
oConn.Open "Provider=ADsDSOObject;"
'What to get and filter criteria
oCmd.CommandText = "SELECT mail, distinguishedname, name, samaccountname from 'LDAP://" & GetNC & "' WHERE objectCategory = 'user' and sn = '" & sLast & "' and givenName = '" & sFirst & "'"
oCmd.activeconnection = oConn
Set oRecSet = oCmd.Execute  'Go get the info if it exists!
If oRecSet.EOF = True And oRecSet.BOF = True Then Exit Function  'Nothing found
For Each objField In oRecSet.Fields
    Debug.Print objField.Name & " = " & objField.Value
    DoEvents
Next objField

oConn.Close
Set oRecSet = Nothing
Set oConn = Nothing
Set oCmd = Nothing

End Function

Function GetNC()
Dim objRoot As Object
    Set objRoot = GetObject("LDAP://RootDSE")
    GetNC = objRoot.get("defaultNamingContext")
    Set objRoot = Nothing
End Function

Trying to find info about accessing AD using VBA is tough for beginners in the AD world. Either there's nothing but C# or C++ code or people who are neck deep in AD and talk at too high of a level

 

[Air_Cooled_Nut]

Interesting...when I clicked reply with quote on Jim's post all his code was there in the quote! The problem is with the left angle bracket and the LDAP://" word that follows it in the tenth line:

 strBase = "<

I placed a space after it and his code shows up. So if you copy this code make sure to remove the space between the left angle bracket (<) and the LDAP://" bit (code line is in bold).

Here's the rest of his code:

'
'****
' Search entire Active Directory domain.
'****
'

Set objRootDSE = GetObject("LDAP://RootDSE")
'Stop
strDNSDomain = objRootDSE.Get("defaultNamingContext")
[B]strBase = "< LDAP://" & strDNSDomain & ">"[/B]

'
'****
' Construct the LDAP query.
'****
'
strAttributes = "sAMAccountName,memberof"
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

'
'****
' Run the query, and get our recordset
'****
'

Set adoRecordset = adoCommand.Execute

cl = 1      'count lines
gl = 1
pl = 1
fl = 1

Application.StatusBar = "Populating Worksheets..."
Set objsheet = Worksheets(wsName)

Do Until adoRecordset.EOF
    arrGroups = adoRecordset.Fields("memberOf").Value
    If IsNull(arrGroups) Then
        gl = gl + 1
        objsheet.Cells(gl, 0).Value = "-- No group memberships"
    Else
        For Each StrGroup In arrGroups
            i = InStr(StrGroup, ",")
            StrGroup = Mid(StrGroup, 4, i - 4)
            If Right(StrGroup, 3) = "_RW" Or Right(StrGroup, 3) = "_RO" Then
                fl = fl + 1
                Set objsheet = Worksheets("Folder")
                tl = fl
            Else
                cl = cl + 1
                Set objsheet = Worksheets(wsName)
                tl = cl
            End If
            i = InStr(StrGroup, ",")
            objsheet.Cells(tl, 1).Value = StrGroup
        Next
    End If
    adoRecordset.MoveNext
Loop

'
'****
' All done, name sheet, sort data, autofit columns, close up and exit
'****
'
'
'****
' to sort the data we have to actually select the required sheet before we can do anything
'****
'

Set objworksheet = Worksheets(wsName)
objworksheet.Select
Set objrange = objworksheet.UsedRange
Set objrange2 = Range(SortByCol)
objrange.Sort objrange2, xlAscending, , , , , , xlYes

ActiveSheet.UsedRange.Columns.EntireColumn.AutoFit

'
'****
' Clean up
'****
'

adoRecordset.Close
adoConnection.Close

Set adoRecordset = Nothing
Set objrange = Nothing
Set objrange2 = Nothing
Set objworksheet = Nothing

End Sub