'Funktion die Informationen über das Active Directory zurück gibt
Public Function GetADSInfo(InfoTyp As Long) As String
Dim CurServer As String
Dim varName As Variant
 
    Set ADSObj = New ActiveDs.ADSystemInfo
 
    CurServer = ADSObj.GetAnyDCName()
 
'   Fallunterscheidung
    Select Case InfoTyp
    Case 1: GetADSInfo = ADSObj.UserName
    Case 2: GetADSInfo = ADSObj.ComputerName
    Case 3: GetADSInfo = ADSObj.SiteName
    Case 4: GetADSInfo = ADSObj.DomainDNSName
    Case 5: GetADSInfo = ADSObj.DomainShortName
    Case 6: GetADSInfo = ADSObj.ForestDNSName
    Case 7: GetADSInfo = ADSObj.GetAnyDCName()
    Case 8: GetADSInfo = ADSObj.GetDCSiteName(CurServer)
    Case 9: ADSObj.RefreshSchemaCache
            GetADSInfo = ADSObj.GetTrees(varName)
    End Select
 
End Function

Private Sub Form_Load()
Dim ds As IADs
'   Die Textfelder der Hauptmaske mit den Active Directory Informationen füllen
    txtADDomain = GetADSInfo(4)
    txtNBDomain = GetADSInfo(5)
    txtSidename = GetADSInfo(3)
    txtPDC = GetADSInfo(7)
 
    Set ds = GetObject("LDAP://RootDSE")
    SLdap = "LDAP://" & ds.Get("defaultNamingContext")
    Set ds = Nothing
'   Auf der Hauptmaske das Steuerelement Listtree füllen
    Call LoadADTree(SLdap)
End Sub
 
Private Function LoadADTree(SLdap As String)
 
Dim ADCont As IADsContainer
Dim ADOU As IADsOU
Dim lstItem As ListItem
Dim lstCount As Long
'   Binden des Objectes ADCont an den Container mit dem Pfad der in sLDAP steht
    Set ADCont = GetObject(SLdap)
'   Filter auf OrganizationalUnit setzten
    ADCont.Filter = Array("OrganizationalUnit")
'   ListTree leeren
    lstTree.ListItems.Clear
'   ListItem hinzufügen
    Set lstItem = lstTree.ListItems.Add(, "Key" & lstCount, "..")
'   dem ListItem ein SubItem hinzufügen
    lstItem.SubItems(1) = SLdap
 
'   Schleife zum befüllen des ListTrees
    For Each ADOU In ADCont
        lstCount = lstCount + 1
        Set lstItem = lstTree.ListItems.Add(, "Key" & lstCount, Mid$(ADOU.Name, _
          InStr(ADOU.Name, "=") + 1))
        lstItem.SubItems(1) = ADOU.ADsPath
    Next
    txtZiel = Mid$(SLdap, 8)
    Set ADCont = Nothing
    Set ADOU = Nothing
End Function