Clever-Excel-Forum

Seiten: 1 2 3

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ß

Hallo,

auch hier hilft eine Beispieldatei beim Helfen.

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?

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

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

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

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

@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"

:(

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

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

Seiten: 1 2 3

EasY

Klaus-Dieter

ralf_b

EasY

ralf_b

EasY

snb

EasY

snb

EasY