Public Function AllUsers(ByVal strAttr As String) As String()
  ' ###################################################################
  ' Hier sind noch einige Attribut-Beispiele
  ' strAttr = "name"  oder strAttr = "cn"   Vorname (Bsp: Peter)
  ' strAttr = "sn"                          Name (Bsp: Müller)
  ' strAttr = "samaccountName"              Kuerzel (Bsp: hede)
  ' strAttr = "telephoneNumber"             Telefon (Bsp: 0815/123)
  ' strAttr = "mail"                        Email (Bsp: asdfg@asdfg.de)
  ' strAttr = "title"                       Titel (Bsp: Dr.)
  ' strAttr = "homeDrive"                   Home-Verzeichnis (Bsp: H:)
  ' strAttr = "physicalDeliveryOfficeName"  Raumnummer (Bsp: C 120)
  ' strAttr = "company"                     Firma (Bsp: Firma GmbH)
  ' strAttr = "postalCode"                  PLZ (Bsp: 12345)
  ' strAttr = "st"                          Bundesland (Bsp: NRW)
  ' strAttr = "streetAddress"               Strasse (Bsp: Am Wald 9a)
  ' strAttr = "l"                           Stadt (Bsp: Köln)
  ' strAttr = "department"                  Abteilung (Bsp: IT)
  ' ###################################################################
  Dim conn As New ADODB.Connection
  Dim Rs As ADODB.Recordset
 
  Dim Root As IADs
  Dim Domain As IADs
 
  Dim strBase As String
  Dim strFilter As String
  Dim strDomain As String
 
  Dim strDepth As String
  Dim strQuery As String
  Dim strUser() As String
  Dim iElement As Integer
 
  ' Fehlerbehandlung aktivieren
  On Error GoTo ErrHandler
 
  ReDim strUser(0) As String
 
  ' Pfad der gegenwärtigen Domäne (LDAP) einholen
  Set Root = GetObject("LDAP://rootDSE")
  strDomain = Root.Get("defaultNamingContext")
  Set Domain = GetObject("LDAP://" & strDomain)
 
  ' LDAP Base DN setzen
  strBase = "<" & Domain.ADsPath & ">"
 
  ' Filter auf die Kategorie Person und Klasse User setzen
  strFilter = "(&(objectCategory=person)(objectClass=user))"
 
  ' falls kein Attribut übergeben wurde, wird es auf ein
  ' beliebiges Standard gesetzt, Bsp: name
  If strAttr = "" Then strAttr = "name"
 
  ' Suchtiefe setzen
  strDepth = "subTree"
 
  ' Abfrage zusammen setzen
  strQuery = strBase & ";" & strFilter & ";" & strAttr & ";" & strDepth
 
  ' Verbindung öffnen
  conn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
 
  ' Query ausführen
  Set Rs = conn.Execute(strQuery)
 
  With Rs
    Do While Not .EOF
      On Error Resume Next
      If strUser(0) = "" Then
        iElement = 0
      Else
        iElement = iElement + 1
      End If
 
      ' das Array Redimensionieren
      ReDim Preserve strUser(iElement) As String
 
      ' Das ausgewählte Attribut (hier: "mail"->Funkstionsübergabe)
      ' in das Array schreiben
      strUser(iElement) = Rs.Fields(strAttr)
 
      .MoveNext
    Loop
  End With
 
  If Rs.State <> 0 Then Rs.Close
  If conn.State <> 0 Then conn.Close
 
ErrExit:
  ' Das StringArray zurückgeben
  AllUsers = strUser
 
  ' Objekte schließen und zerstören
  On Error Resume Next
  Rs.Close
  conn.Close
  Set Rs = Nothing
  Set conn = Nothing
  Set Root = Nothing
  Set Domain = Nothing
  Exit Function
 
ErrHandler:
  Resume ErrExit
End Function

Private Sub Command1_Click()
  Dim strA() As String
  Dim i As Long
 
  ' Funktionsaufruf mit dem Attribut "mail"
  strA = AllUsers("mail")
  If Not strA(0) = "" Then
    For i = 0 To UBound(strA)
      Debug.Print strA(i)
    Next
  End If
End Sub

  ' Pfad der gegenwärtigen Domäne (LDAP) einholen
  Set Root = GetObject("LDAP://rootDSE")
  strDomain = Root.Get("defaultNamingContext")
  Set Domain = GetObject("LDAP://" & strDomain)