Excel: AD-User auslesen und tabellarisch auflisten

Hallo Admins,

ich weiß, die Frage ist bestimmt schon mal gestellt worden. Ich bin aber nicht fündig geworden.
Es geht darum, Benutzereigenschaften in Excel aufgrund der UserID auszulesen. Das soll aber wie folgt passieren...

In meiner Tabelle habe ich in der Spalte A beginnend ab Zelle 3, sprich A3 die UserID´s (Anmeldenamen) tabellarisch untereinander stehen. Ich wollte dann ab Spalte B3 und folgende (C3, D3...) jeweils die Eigenschaften wie eMail, letzte Anmeldung usw. auflisten.

Ich bin kein Power-User und kenne mich daher nicht so gut aus. Lösungsversuche scheiterten bisher.

Das wäre super, wenn jemand mir aus der Schlinge helfen könnte.

Ich danke Euch.

Grüße
v

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 581292

Url: https://administrator.de/contentid/581292

Ausgedruckt am: 08.11.2024 um 05:11 Uhr

10 Kommentare

Neuester Kommentar

HI,
du kannst per Powershell alle Attribute auslesen und in eine CSV Exportieren. DIese kannst du mit Excel bearbeiten und als Excel speichern.

get-aduser -filter * | export-csv c:\temp\export-ad.csv -encoding utf8

Bedenke, das Attribut LastLogonTimeStamp bezieht sich auf den jeweiligen DC der abgefragt wird, falls du mehrere DC's hast kann es sein, dass du abweichende Daten des Feldes bekommst.

Gruß

Hi,

das ist gut, aber nicht anwendbar. Ich habe eine Userliste in Spalte A einer Tabelle1 der Arbeitsmappe "Benutzerabfrage.xlsx". Ich benötige den Inhalt der Eigenschaften (eMail etc) dieser User, welche in A3 beginnend aufgelistet sind, in den Spalten B und folgende.

Ich möchte einfach einen Knopf "getUserInfo" klicken, der mir zu den genannten ID´s den Vornamen + Nachnamen (fullName), eMail, Lastlogon und is locked ausgibt.

Ich habe mir mal was zurechtgeschnippelt... das klappt aber nicht.

Was ich noch wissen muss, ist, ob der User überhaupt noch existiert. Das Programm sollte nicht stoppen sondern nur "ist nicht vorhanden" ausgeben und zur nächsten Zeile springen.

Vielleicht hast du eine Idee dazu.

Grüße und Danke

v

Option Explicit

Public Sub Command1_Click()

Dim f As Integer
Dim Zeile As Integer
Dim kname As String
Dim team As String
Dim sp As String
Dim InStr As String
Dim NName As String
Dim VName As String
Dim objSysInfo
Dim objUser
Dim FullName
Dim Email
Dim Description
Dim FaxNumber
Dim PhoneNumber

For f = 2 To Zeile - 1
        kname = Sheets("Tabelle1").Range("b" & CStr(f)).Text  
        team = ""  
        If kname <> "" Then  
            sp = InStr(kname, ", ")  
            If sp <> 0 Then
                 Dim qQuery As String
    ' den Vor und Nachnamen aus der Tabelle holen  
    NName = Left$(kname, sp - 1)
                VName = Right$(kname, Len(kname) - sp - 1)
         
                ' Active Directory Informationen f?r den angemeldeten User lesen  
                Set objSysInfo = CreateObject("ADSystemInfo")  
                objSysInfo.RefreshSchemaCache
                qQuery = "LDAP://CN=" & NName & "\, " & VName & ",OU=technik),DC=uni.edu"  
                Sheets("Tabelle1").Range("a3").FormulaR1C1 = qQuery  
                On Error Resume Next
                Set objUser = GetObject(qQuery)
                'Variablen mit AD-Attributen f?llen (es gibt viel mehr Attributen zb. FaxNumber usv.)  
                FullName = objUser.FirstName & " " & objUser.lastname  
                Email = objUser.mail
                team = objUser.department
                Description = objUser.Description
                PhoneNumber = objUser.telephoneNumber
                Sheets("Tabelle1").Range("b" & CStr(f)).Value = FullName  
                Sheets("Tabelle1").Range("C" & CStr(f)).Value = Email  
                FaxNumber = objUser.facsimileTelephoneNumber
                objUser.department = ""  
                objUser.Description = ""  
                objUser.FirstName = ""  
                objUser.FirstName = ""  
            
            End If
        End If
    If team <> "" Then  
    Sheets("Tabelle1").Range("c" & CStr(f)).Value = team  
    End If
Next f
End Sub

HI,
ich nutze immer nur die Powershell Variante. Wie du das in Excel bastelst kann ich dir nicht sagen.
Du kannst es ja raus ziehen und dann via SVerweis oder ähnlichen zusammen suchen.

Gruß

Hi,
das ist auch eine Lösungsmöglichkeit, benötigt aber wieder einen extra aufwand. du musst die CSV generieren und musst es noch filtern.

Wenn ich die Tabelle beispielsweise immer wieder brauche, dann ist die angestrebte Lösung in Excel besser.

Grüße
v

Servus.

Sub GetAccountInfo()
    On Error Resume Next
    ' ad properties to extract for users  
    arrProps = Array("Description", "givenname", "sn", "mail", "department")  
    ' column headers matching array positions of 'arrProps'  
    arrColumnHeaders = Array("Beschreibung", "Vorname", "Nachname", "E-Mail", "Abteilung")  
    ' wotking on current sheet  
    With ActiveSheet
        ' set column headers and format  
        With .Range("B2").Resize(1, UBound(arrColumnHeaders) + 1)  
            .Value = arrColumnHeaders
            .EntireRow.Font.Bold = True
        End With
        ' for each used cell in column A3:A(n)  
        For Each cell In .Range("A3: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)
                ' 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 = "User not found."  
                    ' and fill entire row with yellow color  
                    cell.EntireRow.Interior.Color = vbYellow
                End If
            End If
        Next
    End With
End Sub

Function FindAccount(strUserName)
    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)(SamAccountName=" & strUserName & "))"  
    
    ' 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

Grüße Uwe

Hi Uwe,

super, so habe ich mir das vorgestellt. Wie bringe ich der Tabelle noch bei, wann sich der Benutzer das letzte mal angemeldet hat und ob das Konto deaktiviert wurde?

und wie lösche ich die gelben Linien beim erneuten drücken der "Get Name"-Taste?

Das wäre noch die Königsklasse.

Vielen Dank für die Hilfe.

Grüße
v

Ohne Schießgewehr ..
(zu LastLogon s. Hinweis der Kollegen oben)

Sub GetAccountInfo()
    On Error Resume Next
    ' ad properties to extract for users  
    arrProps = Array("Description", "givenname", "sn", "mail", "department", "UserAccountControl", "lastLogon")  
    ' column headers matching array positions of 'arrProps'  
    arrColumnHeaders = Array("Beschreibung", "Vorname", "Nachname", "E-Mail", "Abteilung", "Status", "Letzte Anmeldung")  
    ' wotking on current sheet  
    With ActiveSheet
        ' set column headers and format  
        With .Range("B2").Resize(1, UBound(arrColumnHeaders) + 1)  
            .value = arrColumnHeaders
            .EntireRow.Font.Bold = True
        End With
        ' for each used cell in column A3:A(n)  
        For Each cell In .Range("A3: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)
                ' if user found  ...  
                If Not result Is Nothing Then
                    ' reset background color  
                    cell.EntireRow.Interior.ColorIndex = xlNone
                    ' for each property  
                    For i = 0 To UBound(arrProps)
                        ' UAC Value check  
                        If arrProps(i) = "UserAccountControl" Then  
                            cell.Offset(0, i + 1).value = IIf(result.Get(arrProps(i)) And 2, "Deaktiviert", "Aktiviert")  
                        ' convert last logon to date  
                        ElseIf arrProps(i) = "lastLogon" Then  
                            r = result.Get(arrProps(i))
                            cell.Offset(0, i + 1).value = LargeIntegerToDate(result.Get(arrProps(i)))
                        Else
                            cell.Offset(0, i + 1).value = result.Get(arrProps(i))
                        End If
                        
                    Next
                Else    ' user not found  
                    ' fill entire row with yellow color  
                    cell.EntireRow.Interior.Color = vbYellow
                End If
            End If
        Next
    End With
End Sub

Function FindAccount(strUserName)
    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)(SamAccountName=" & strUserName & "))"  
    
    ' 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

Function LargeIntegerToDate(value)
'nimmmt einen  Microsoft LargeInteger Wert (Intger8) und gibt das entsprechende Datum plus Uhrzeit zurück  

    'erst die lokale Zeitabweichung aus der Registry auslesen  
    Set sho = CreateObject("Wscript.Shell")  
    timeShiftValue = sho.RegRead("HKLM\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")  
    If IsArray(timeShiftValue) Then
        timeShift = 0
        For i = 0 To UBound(timeShiftValue)
            timeShift = timeShift + (timeShiftValue(i) * 256 ^ i)
        Next
    Else
        timeShift = timeShiftValue
    End If

    'der Large Integer wird mit zwei Long Werten gehandhabt (HighPart und LowPart)  
    i8High = value.HighPart
    i8Low = value.LowPart
    If (i8Low < 0) Then
           i8High = i8High + 1
    End If

    'das Datum und die Uhrzeit ausrechnen: 100-Nanosecond-Schritte seit dem 1. Januar 1601  
    If (i8High = 0) And (i8Low = 0) Then
        LargeIntegerToDate = #1/1/1601#
    Else
        LargeIntegerToDate = #1/1/1601# + (((i8High * 2 ^ 32) + i8Low) / 600000000 - timeShift) / 1440
    End If
End Function

Mehr "Wünsch dir was" gibt es von meiner Seite jetzt nur noch per PN.

Grüße Uwe

Hi Uwe,

du bist klasse, ich verneige mich vor dir

Tag gerettet, ich kann heim gehen

Grüße
v

Ach Uwe, ich kenn dich nicht persönlich, lese aber immer wieder von dir und muss mich einfach mal heute nochmals bedanken! Dein Backupscript läuft heute noch wie geschnitten Brot! Danke das es dich gibt!

Beste Grüße