Recursive approach to retrieve all elements of the Active Directory 'forest' (XL2007)

[AOB]

Hi guys,

I'm trying to query ActiveDirectory to see the complete 'forest' of information available - all OU's, sub-OU's, CN's etc.

The problem is, I don't know how many branches there are to any given subtree (and the number can vary from branch to branch, obviously)

I can create a nested For/Next loop, but with a non-recursive method, I have to hard-code a new loop for each potential sub-element

For example, to see up to 2 levels (beyond the GC domain), I could use this :

Option Explicit

Private Function QueryActiveDirectory() As Object
    
    On Error GoTo ERR_QAD
    
    Dim oGC As Object
    Dim oDomainEnum As Object
    Dim oDomainBind As Object
    Dim oChild1 As Object
    Dim oChild2 As Object
    
    Dim sht As Worksheet
    Dim rng As Range

    Set sht = ThisWorkbook.Sheets("Output")
    
    With sht
        .Cells.Delete
        Set rng = .Range("A1")
    End With
    
    With rng
        .Value = "Domain"
        .Offset(, 1).Value = "Child1"
        .Offset(, 2).Value = "Child2"
    End With
    
    Set rng = rng.Offset(1)
    
    With rng
    
        Set oGC = GetObject("GC:")
    
        For Each oDomainEnum In oGC
            ' Print the name of the domain.
            .Value = oDomainEnum.Name

            ' Bind to the domain.
            Set oDomainBind = GetObject("LDAP://" & oDomainEnum.Name)
    
            ' Enumerate the child objects of the domain.
            For Each oChild1 In oDomainBind
                Call AddToList(rng, oChild1.Name, 1)
                For Each oChild2 In oChild1
                    Call AddToList(rng, oChild2.Name, 2)
                Next
            Next
        Next
    
    End With

EXIT_QAD:

    Exit Function

ERR_QAD:

    Debug.Print Err.Number
    Debug.Print Err.Description
    Debug.Print Err.Source
    Resume EXIT_QAD

End Function

With this as my sub-function to print the result to the worksheet :

Private Sub AddToList(ByRef rng As Range, ByVal strValue As String, ByVal lngPosition As Long)

    Dim i As Long
    
    If Len(rng.Offset(, lngPosition).Value) = 0 Then
        ' Continuation of existing line
        rng.Offset(, lngPosition).Value = strValue
    Else
        ' New line
        Set rng = rng.Offset(1)
        ' Fill from previous line
        For i = 0 To lngPosition - 1
            rng.Offset(, i).Value = rng.Offset(-1, i).Value
        Next i
        rng.Offset(, lngPosition).Value = strValue
    End If

End Sub

But if I want to see the next (third) level down (if one exists), I have to hardcode another loop :

With rng
    
    Set oGC = GetObject("GC:")
    
    For Each oDomainEnum In oGC
        ' Print the name of the domain.
        .Value = oDomainEnum.Name

        ' Bind to the domain.
        Set oDomainBind = GetObject("LDAP://" & oDomainEnum.Name)
    
        ' Enumerate the child objects of the domain.
        For Each oChild1 In oDomainBind
            Call AddToList(rng, oChild1.Name, 1)
            For Each oChild2 In oChild1
                Call AddToList(rng, oChild2.Name, 2)
                [COLOR="#FF0000"]For Each oChild3 In oChild2
                  Call AddToList(rng, oChild3.Name, 3)
                Next[/COLOR]
            Next
        Next
    Next
    
End With

And again for a 4th, or 5th, or 6th - and so on and so on - until I eventually find no child elements (I have no idea how deep down the rabbit hole this may go)

Can anybody suggest a recursive approach which would allow me to code this to produce an output regardless of how many levels a given branch could hold?

(PS - I am aware of the risks of recursion, infinite looping etc. - so suggestions on a failsafe or cutoff to prevent this would also be welcomed - they don't call it a forest for nothing and I don't want to create issues where they can be avoided!!)

Thanks in advance!

Al