Um eine Auswertung der letzten Anmeldung von Benutzern zu erstellen habe ich das folgende Skript genutzt.
Es können mehrere Anpassungen durchgeführt werden:
– Domäne => dc=domain,dc=local
– Ausschließen von deaktivierten Konten => (!userAccountControl:1.2.840.113556.1.4.803:=2)
– Anpassung der Zeit auf alle Anmeldungen älter 90 Tage =>Format(Now() - 90
Das Skript muss einfach nur aus Excel gestartet werden und man erhält eine sehr übersichtliche Liste. Es ist allerdings zu beachten, dass der Wert "LastLogonTimeStamp" ein sychnronisierter Wert ist und nicht unbedingt tagesaktuell.
Option Explicit Const ADS_UF_ACCOUNTDISABLE = 2 Const ADS_SCOPE_SUBTREE = 2 Const ADS_UF_DONT_EXPIRE_PASSWD = 65536 Const FLD_FULLNAME = 1 Const FLD_SAM_ACCTNAME = 2 Const FLD_CREATEDATE = 3 Const FLD_PWD_LASTCHNG = 4 Const FLD_PWD_DONTEXPIRE = 5 Const FLD_UAC = 6 Const FLD_LASTLOGON = 7 Const FLD_ADSPATH = 8 Const FLD_MAX = 8 Const HEADROW = 1 Const ASCII_OFFSET = 64 Sub AD_QUERY() Dim objUser, objLogon, objConnection, objCommand, objRecordSet Dim strPath, strFullName, strSamAccountName Dim intUAC, intLogonTime Dim createdate, pwdchanged Dim Disabled, PWDexpire, intCounter Dim objsheet As Excel.Worksheet Dim rngData As Excel.Range Set objConnection = CreateObject("ADODB.Connection") Set objCommand = CreateObject("ADODB.Command") objConnection.Provider = "ADsDSOObject" objConnection.Properties("ADSI Flag") = 1 objConnection.Open "Active Directory Provider" Set objCommand.ActiveConnection = objConnection objCommand.Properties("Page Size") = 10000 objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 'Search AD Global catalog for user objects that are not disabled objCommand.CommandText = "<GC://dc=domain,dc=local>; (&(objectClass=user)(objectCategory=person));adspath, samAccountName; subtree" Application.StatusBar = "Executing AD Query. Please wait..." Set objRecordSet = objCommand.Execute Application.StatusBar = "Populating Worksheet with data. Please wait..." Set objsheet = Application.ActiveWorkbook.Worksheets.Add() objsheet.Name = Format(Date, "dd-mm-yyyy") & " Raw Data" intCounter = 2 'Initialise worksheet row counter objsheet.Cells(HEADROW, FLD_FULLNAME).Value = "Full Name" objsheet.Cells(HEADROW, FLD_SAM_ACCTNAME).Value = "SAM Account name" objsheet.Cells(HEADROW, FLD_CREATEDATE).Value = "Create Date (UTC)" objsheet.Cells(HEADROW, FLD_PWD_LASTCHNG).Value = "PWD Last Changed" objsheet.Cells(HEADROW, FLD_PWD_DONTEXPIRE).Value = "PWD Don't Expire" objsheet.Cells(HEADROW, FLD_UAC).Value = "UAC" objsheet.Cells(HEADROW, FLD_LASTLOGON).Value = "LastLogonTimestamp" objsheet.Cells(HEADROW, FLD_ADSPATH).Value = "ADSPATH" objRecordSet.MoveFirst Do Until objRecordSet.EOF strPath = objRecordSet.Fields("adspath") 'Change the global catalog path to an ldap path so that we can access 'all the attributes when binding to the object. strPath = Replace(strPath, "GC://", "LDAP://") Set objUser = GetObject(strPath) intUAC = objUser.userAccountControl If (intUAC And ADS_UF_DONT_EXPIRE_PASSWD) = 0 Then PWDexpire = False Else PWDexpire = True End If On Error Resume Next Err.Clear 'Set objLogon = objUser.LastLogonTimestamp Set objLogon = objUser.LastLogon If Err.Number <> 0 Then intLogonTime = 0 Err.Clear Else intLogonTime = objLogon.HighPart * (2 ^ 32) + objLogon.LowPart intLogonTime = intLogonTime / (60 * 10000000) intLogonTime = intLogonTime / 1440 End If strFullName = objUser.FullName If Err.Number <> 0 Then strFullName = "" Err.Clear End If createdate = objUser.whenCreated If Err.Number <> 0 Then createdate = "" Err.Clear End If pwdchanged = objUser.passwordLastChanged If Err.Number <> 0 Then pwdchanged = "" Err.Clear End If On Error GoTo 0 strSamAccountName = objUser.SamAccountName objsheet.Cells(intCounter, FLD_FULLNAME).Value = strFullName objsheet.Cells(intCounter, FLD_SAM_ACCTNAME).Value = strSamAccountName objsheet.Cells(intCounter, FLD_CREATEDATE).Value = createdate objsheet.Cells(intCounter, FLD_PWD_LASTCHNG).Value = pwdchanged objsheet.Cells(intCounter, FLD_PWD_DONTEXPIRE).Value = PWDexpire objsheet.Cells(intCounter, FLD_UAC).Value = intUAC If intLogonTime <> 0 Then objsheet.Cells(intCounter, FLD_LASTLOGON).Value = intLogonTime + #1/1/1601# Else objsheet.Cells(intCounter, FLD_LASTLOGON).Value = "#1/1/1601#" End If objsheet.Cells(intCounter, FLD_ADSPATH).Value = strPath objRecordSet.MoveNext intCounter = intCounter + 1 Loop Set rngData = objsheet.Range("A1:" & Chr(ASCII_OFFSET + FLD_MAX) & intCounter - 1) 'if the named range already exists we need to delete is before we create it again. 'This will allow more than one audit set to be retained in the same workbook. On Error Resume Next ActiveWorkbook.Names("AD_DATA_SET").Delete On Error GoTo 0 rngData.Name = "AD_DATA_SET" rngData.Columns.AutoFit Application.StatusBar = "Ready" End Sub Sub filter_lastlogon() Dim rngData As Excel.Range Set rngData = Range("AD_DATA_SET") rngData.Worksheet.AutoFilterMode = False 'Filter function seems to ignore locale info so dates must be in US format rngData.AutoFilter Field:=FLD_LASTLOGON, Criteria1:="=#1/1/1601#", Operator:=xlOr, _ Criteria2:="<" & Format(Now() - 90, "mm/dd/yyyy") End Sub Sub filter_pwd_dontexpire() Dim rngData As Excel.Range Set rngData = Range("AD_DATA_SET") rngData.Worksheet.AutoFilterMode = False rngData.AutoFilter Field:=FLD_PWD_DONTEXPIRE, Criteria1:="=True" End Sub Sub RemoveFilter() Dim rngData As Excel.Range Set rngData = Range("AD_DATA_SET") rngData.Worksheet.AutoFilterMode = False End Sub Sub CopyPW() 'Copies the filtered data to a new Worksheet 'Code modified from http://www.contextures.com/xlautofilter03.html#Copy 'Viewed 7/6/2007 Dim rngData As Excel.Range Dim rng As Range Dim rng2 As Range Dim objsheet As Worksheet Set rngData = Range("AD_DATA_SET") Call filter_pwd_dontexpire If Not rngData.Worksheet.FilterMode Then MsgBox "Filter Data before selecting this option", vbExclamation Exit Sub End If With rngData.Worksheet.AutoFilter.Range On Error Resume Next Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _ .SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With If rng2 Is Nothing Then MsgBox "No data to copy" Else Set objsheet = Application.ActiveWorkbook.Worksheets.Add() objsheet.Name = Format(Date, "dd-mm-yyyy") & " Password dont expire" Set rng = rngData.Worksheet.AutoFilter.Range rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _ Destination:=objsheet.Range("A2") objsheet.Cells(HEADROW, FLD_FULLNAME).Value = "Full Name" objsheet.Cells(HEADROW, FLD_SAM_ACCTNAME).Value = "SAM Account name" objsheet.Cells(HEADROW, FLD_CREATEDATE).Value = "Create Date (UTC)" objsheet.Cells(HEADROW, FLD_PWD_LASTCHNG).Value = "PWD Last Changed" objsheet.Cells(HEADROW, FLD_PWD_DONTEXPIRE).Value = "PWD Don't Expire" objsheet.Cells(HEADROW, FLD_UAC).Value = "UAC" objsheet.Cells(HEADROW, FLD_LASTLOGON).Value = "LastLogonTimestamp" objsheet.Cells(HEADROW, FLD_ADSPATH).Value = "ADSPATH" objsheet.Columns.AutoFit End If End Sub Sub CopyLstLogon() 'Copies the filtered data to a new Worksheet 'Code modified from http://www.contextures.com/xlautofilter03.html#Copy 'Viewed 7/6/2007 Dim rngData As Excel.Range Dim rng As Range Dim rng2 As Range Dim objsheet As Worksheet Set rngData = Range("AD_DATA_SET") Call filter_lastlogon If Not rngData.Worksheet.FilterMode Then MsgBox "Filter Data before selecting this option", vbExclamation Exit Sub End If With rngData.Worksheet.AutoFilter.Range On Error Resume Next Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _ .SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With If rng2 Is Nothing Then MsgBox "No data to copy" Else Set objsheet = Application.ActiveWorkbook.Worksheets.Add() objsheet.Name = Format(Date, "dd-mm-yyyy") & " LastLogon > 90 days" Set rng = rngData.Worksheet.AutoFilter.Range rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _ Destination:=objsheet.Range("A2") objsheet.Cells(HEADROW, FLD_FULLNAME).Value = "Full Name" objsheet.Cells(HEADROW, FLD_SAM_ACCTNAME).Value = "SAM Account name" objsheet.Cells(HEADROW, FLD_CREATEDATE).Value = "Create Date (UTC)" objsheet.Cells(HEADROW, FLD_PWD_LASTCHNG).Value = "PWD Last Changed" objsheet.Cells(HEADROW, FLD_PWD_DONTEXPIRE).Value = "PWD Don't Expire" objsheet.Cells(HEADROW, FLD_UAC).Value = "UAC" objsheet.Cells(HEADROW, FLD_LASTLOGON).Value = "LastLogonTimestamp" objsheet.Cells(HEADROW, FLD_ADSPATH).Value = "ADSPATH" objsheet.Columns.AutoFit End If End Sub
Als Gundlage wurde das Skript von der folgenden Seite eingesetzt:
Link
Hallo ich habe mal eine Frage ist es möglich eine Excel mit Passwortschutz zu versehen in welcher der User alle 90 Tage selbst das Passwort ändern kann bzw. muss?
Danke Gruß Reiner
Hallo Herr Sieger,
Wenn das Passwort geändert werden soll, muss dem User dieses bekannt sein.
Alternative wäre eine „3rd-Party-Lösung“ zum Entfernen des Passworts, wobei allerdings dort viele Antiviren-Software Meldungen senden sollten.
Der Schreibschutz muss an der Stelle über eine andere Lösung wie Berechtigung am Speicherort und Kontorichtlinien für den User realisiert werden
Liebe Grüße
Daniel