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

Ich schreibe häufig e_Mails, bei denen Personen auf CC hinzufgefügt werden sollen. Diese sind bei mir im Regelfall 4 Personen.

Da man im Eifer des Gefechts an der E-Mail-Front diese mal vergessen kann, habe ich mir ein Makro gebaut, welches mich beim Versand einer E-Mail fragt, ob die Mailadressen der Personen im CC-Feld hinzugefügt werden sollen.

Hier das Skript:

Private Sub Application_ItemSend (ByVal Item As Object, cancel as Boolean)
 
If MsgBox("Person 1?", vbYesNo + vbQuestion) = vbYes Then
    Set objMe = Item.Recipients.Add("Person1@mail.de")
        objMe.Type = olCC
   End If
 
If MsgBox("Person 2?", vbYesNo + vbQuestion) = vbYes Then
    Set objMe = Item.Recipients.Add("Person2@mail.de")
        objMe.Type = olCC
   End If
 
If MsgBox("Person 3?", vbYesNo + vbQuestion) = vbYes Then
    Set objMe = Item.Recipients.Add("Person3@mail.de")
        objMe.Type = olCC
   End If
 
   If Not objMe = "" Then
           objMe.Resolve
    Set objMe = Nothing
   End If
End Sub

Wenn man nun eine Mail absenden will, wird man automatisch mit Message-Boxen gefragt, ob man Person 1-3 dem Feld hinzufügen möchte.

Zur Erstellung von Passwörtern unter Excel habe ich am gestrigen Abend ein VBA-Skript erstellt, bei den man die Anzahl der Passwörter sowie auch die Anzahl der Zeichen bei jedem Aufruf definieren kann. Desweiteren können die zu nutzenden Ieichen beim Passwort ebenfalls editiert werden.

Sub PasswortErstellung()
 
  Dim myArray As Variant
  myArray = Array("", 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, "A", "B", _
            "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
            "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
            "a", "b", _
            "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", _
            "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", _
            ":", "-", "_", "!", "§", "$", "%", "&", "/", "(", _
            ")", "=", "?", "#", "+")
 
  Dim VarAnzahl2 As Integer
  VarAnzahl2 = UBound(myArray)
 
  Dim VarAnzahl As Variant
  VarAnzahl = Application.InputBox("Anzahl der zu generierenden Passwörter:", "Passwort-Erstellung", 10, , , , , 1)
 
  Dim VarLaenge As Variant
  VarLaenge = Application.InputBox("Wieviele Zeichen soll das Passwort haben?", "Passwort-Erstellung", 8, , , , , 1)
 
  Dim VarColumn As Integer
  Dim VarPassword As Integer
  Dim VarRow As Integer
  Dim StrgPassword As String
 
  If Not TypeName(VarAnzahl) = "Boolean" Then
    Randomize
    VarColumn = ActiveCell.Column
    VarRow = ActiveCell.Row
    For VarRow = VarRow To VarRow + VarAnzahl
      For VarPassword = 1 To VarLaenge
        StrgPassword = StrgPassword & myArray(Int(VarAnzahl2 * Rnd + 1))
      Next VarPassword
      If Application.WorksheetFunction.CountIf(ActiveCell.EntireColumn, StrgPassword) = 0 Then
        ActiveSheet.Cells(VarRow, VarColumn).Value = StrgPassword
      End If
      StrgPassword = ""
    Next VarRow
  End If
End Sub

Die Passwörter werden ab der Zeile geschrieben, die als aktiv makiert ist.

Gestern bekam ich eine Anfrage, ob man eine E-Mail aus Excel versenden kann in der das Dokument als Anhang eingefügt ist.

Zu dieser Anforderung kann man folgenden Code verwenden:

Sub Mailversand()
Dim Nachricht As Object, OutlookApplication As Object
Set OutlookApplication = CreateObject("Outlook.Application")
Dim Anhang As String
Anhang = ThisWorkbook.FullName
Set Nachricht = OutlookApplication.CreateItem(0)
With Nachricht
.To = "mailadresse@domain.tld"
.Subject = "Betreff "
.attachments.Add Anhang
.Body = "Mailtext" & vbCrLf & vbCrLf
.Display
'.Mail.Send
End With
Set OutlookApplication = Nothing
Set Nachricht = Nothing
End Sub

Wenn man das Apostroph vor dem Befehl “.Mail.Send” entfernt, wird die Mail direkt versandt.