Excel: AD-User auslesen und tabellarisch auflisten

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

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