Benutzer der gegenwärtigen Domäne auslesen Dieser Tipp zeigt, wie sich die Benutzer und deren angelegten Daten in der gegenwärtigen Domäne aus dem LDAP, mittels ADSI, auslesen lassen
Autor:   Dennis Hemken	Bewertung:     [ Jetzt bewerten ]	Views:  40.293
gadgets.hemken.org	System:  WinXP, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 41 Bewertung insgesamt: sehr gut Durchschnittliche Bewertung: 5.0 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Mit dieser Funktion ist man in der Lage, alle Benutzer und deren angelegte Daten in der gegenwärtigen Domäne aus dem LDAP, mittels ADSI (ADSI = Active Directory Service Interface) auszulesen und in einem StringArray zurückzugeben. Eine andere Funktion, die sich ebenfalls mit dem Auslesen des LDAP beschäftigt, findet ihr hier:  Computer der gegenwärtigen Domäne auslesen.

Ergänzung: Diese beiden Funktionen können, so wie sie hier stehen, nur mit VB6 ausgeführt werden, da die Vorgängerversionen noch kein StringArray kennen.

Um diese Funktion auszuführen, müssen folgende Verweise eingefügt werden:

• Microsoft ActiveX Data Objects 2.5 Libary
• Active DS Type Libary

Die Funktion arbeitet mit einem Übergabeparameter, der das Attribut beinhaltet, das ausgelesen werden soll.

Quellcode:

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

Beispiel für den Auruf der Funktion:

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