VBA - LDAP-Abfrage

[EasY]

Moin moin,

ich habe ein Makro, welches das LDAP-Verzeichnis "anzapft" und eine Liste mit Namen und Vornamen abfragt und dann weitere Infos wie E-Mail-Adresse ergänzt. Das klappt auch soweit ganz gut. Allerdings kommt es nicht selten vor, dass es mehrere Personen mit identischem Vor- und Nachnamen gibt. Ich möchte die Prozedur dann an der Stelle unterbrechen und z.B. in einer Userform die entsprechenden Infos darstellen, sodass der User sich die gesuchte Person aussuchen kann. Danach soll die Prozedur fortgeführt werden.
Da ich das Makro nicht selbst gebaut habe und es entsprechend auch nicht vollends verstehe, was da passiert, weiß ich nicht, an welcher Stelle ich ansetzen könnte. Eine Userform basteln dürfte ich hinbekommen - das dauert bei mir allerdings ein wenig :).

Wäre super, wenn mir wer auf die Sprünge helfen könnte.

Das Makro sieht wie folgt aus:

Code:

Sub GetAccountInfo()
    On Error Resume Next
    ' ad properties to extract for users
    arrProps = Array("givenName", "mail", "samAccountName", "department", "memberOf")
    ' column headers matching array positions of 'arrProps'
    arrColumnHeaders = Array("givenName", "E-Mail", "samAccountName", "department")
    ' working on current sheet
    With ThisWorkbook.Sheets("Mitarbeiter")
        ' for each used cell in column C2:I(n)
        For Each cell In .Range("A6:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
            ' if value is not empty
            If cell.Value <> "" Then
                ' search user in ad
                Set result = FindAccount(cell.Value, cell.Offset(0, 1).Value)
                ' if user found  ...
                If Not result Is Nothing Then
                    For i = 0 To UBound(arrProps)
                        cell.Offset(0, i + 1).Value = result.Get(arrProps(i))
                    Next
                Else    ' user not found
                    ' write info to next cell
                    cell.Offset(0, 1).Value = "Mitarbeiter nicht gefunden"
                End If
            End If
        Next
    End With
End Sub

Function FindAccount(strUserName, strUserVorname)
    On Error Resume Next
    Dim adoCommand, adoConnection
    Dim varBaseDN, varFilter
    Dim objRootDSE, varDNSDomain, strQuery, adoRecordset

    Set adoCommand = CreateObject("ADODB.Command")
    Set adoConnection = CreateObject("ADODB.Connection")
    adoConnection.Provider = "ADsDSOObject"
    adoConnection.Open "Active Directory Provider"
    Set adoCommand.ActiveConnection = adoConnection
   
    ' Search entire Active Directory domain.
    Set objRootDSE = GetObject("LDAP://RootDSE")
   
    varDNSDomain = objRootDSE.Get("defaultNamingContext")
    varBaseDN = "<LDAP://" & varDNSDomain & ">"
   
    ' Filter for user objects.
    varFilter = "(&(objectCategory=person)(objectClass=user)(sn=" & strUserName & ")(givenName=" & strUserVorname & "))"
   
    ' Construct the LDAP syntax query.
    adoCommand.CommandText = varBaseDN & ";" & varFilter & ";ADSPath;Subtree"
    adoCommand.Properties("Page Size") = 2
    adoCommand.Properties("Timeout") = 20
    adoCommand.Properties("Cache Results") = False
    Set adoRecordset = adoCommand.Execute
    adoRecordset.MoveFirst

    If adoRecordset.RecordCount > 0 Then
        Set FindAccount = GetObject(adoRecordset("ADSPath"))
    Else
        Set FindAccount = Nothing
    End If
   
    adoRecordset.Close
    adoConnection.Close
End Function

Danke und Gruß

[Klaus-Dieter]

Hallo,

auch hier hilft eine Beispieldatei beim Helfen.

[ralf_b]

Findaccount müßte alle Suchergebnisse zurückgeben und nicht nur den ersten Treffer. 
Die Rückgabe dann prüfen ob es mehr als ein Treffer ist und dann eine Userform öffnen und in z.b. eine Listbox die Ergebnisse schreiben.
bei Klick auf einen Eintrag, die Werte in die Tabelle schreiben und die Userform schließen. 
 
Sind das genug Sprunghilfen?

[EasY]

Hier ist sie :)

---

@ralf_b

Code:

if Findaccount(cell.value,cell.offset(0,1).value) > 1 then
userform.show

else
Set result = FindAccount(cell.Value, cell.Offset(0, 1).Value)

so in der Form funktioniert es leider nicht

[ralf_b]

das liegt daran das findaccount immer nur ein Ergebnis zurückgibt oder nichts

und deine Beispieldatei hilft hier nicht weiter wenn man kein LDAP-verzeichnis hat.  

Code:

'hier wird das erste Ergebnis angesteuert.
adoRecordset.MoveFirst

If adoRecordset.RecordCount > 0 Then
    Set FindAccount = GetObject(adoRecordset("ADSPath"))
Else
    Set FindAccount = Nothing
End If

[EasY]

Mh das ist natürlich ärgerlich - ein LDAP-Verzeichnis kann ich leider nicht zu euch zaubern

[snb]

Eigener Code ???

Verzichte auf den Function.
Die Arrays sind überflüssig.

Hier reicht:

Code:

Sub M_snb()
   Set C_onn = CreateObject("ADODB.Connection").Provider = "ADsDSOObject"
   C_onn.Open "Active Directory Provider"
   
   With ThisWorkbook.Sheets("Mitarbeiter")
    For Each it In UsedRange.Columns(1).Offset(5).SpecialCells(2)
     c00 = "(&(objectCategory=person)(objectClass=user)(sn=" & it & ")(givenName=" & it.Offset(, 1) & "))"
     With C_onn.activeconnection
       .CommandText = "<LDAP://" & GetObject("LDAP://RootDSE").Get("defaultNamingContext") & ">;" & c00 & ";ADSPath;Subtree"
       .Properties("Page Size") = 2
       .Properties("Timeout") = 20
       .Properties("Cache Results") = False
       Set sn = .Execute
       it.Offset(, 2).Resize(, 4).copyformrecordset sn.DataSource
     End With
   Next
  End With
End Sub

[EasY]

@snb
nein nein, es ist nicht mein eigener Code, das habe ich auch geschrieben :).

Wie immer verstehe ich deine Codes noch weniger (positiv gemeint). Habe den Code gerade ausprobiert und der Debugger geht direkt in der ersten Codezeile los "Laufzeitfehler 13 - Typenunverträglichkeit"

:(

[snb]

vesuch's mal so:

Code:

with CreateObject("ADODB.Connection")
   .Provider = "ADsDSOObject"
   .Open "Active Directory Provider"
   set C_onn =.activeconnection
  end with

ubd später:

statt

Code:

With C_onn.activeconnection

Code:

With C_onn

[EasY]

Das funktioniert und hat den Code deutlich eingekürzt - danke dafür. Allerdings löst das noch nicht mein Problem :)