|
Als erstes möchte ich dir sehr danken dass du mir hilfst weiter zu kommen. Jedoch wenn ich das Skript ausführe ladet es bloss und es passiert rein garnichts.
Ich weiss nicht an was das liegen könnte habe es 1zu1 übernommen und die Einstellung für den Server geändert.
Viele Grüsse
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 "Provider=ADSDSOObject; User Id=*********;Password=*********;"
' 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
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
|