Category Archives: VBA

E-Mail mit Anhang versenden über VBA & mit Signatur

Zu meinem Artikel „E-Mail mit Anhang versenden über VBA“ gab es gestern einen Kommentar.

In diesem wurde ein Problem aufgebracht, welches sich nicht ganz so einfach lösen lies. Es sollte eine Funktion genutzt werden, die seit Office 2013 nicht mehr zur Verfügung steht. Der Befehlsaufruf hätte die vordefinierte Signatur an das Ende der E-Mail gesetzt werden sollen. Dieses habe ich wie folgt gelöst:

Sub MailversandSignatur()
 
Dim sPath As String
Dim strUser As String
Dim strPfad As String
Dim strSignatur As String
Dim Body As String
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 = "testuser@testdomain.de"
.Subject = "Test"
.Attachments.Add Anhang
 
'Namen der Signatur definieren
strSignatur = "TestSignatur"
 
strUser = Environ("Userprofile")
strPfad = strUser & "\AppData\Roaming\Microsoft\Signatures\" & strSignatur & ".htm"
.htmlBody = "<html><body><p>Sehr geehrte Damen und Herren,</p><p>im Anhang erhalten Sie die Liste.</p><p></p>" & test(strPfad) & "</body></html>"
 
.Display
'.Mail.Send
 
End With
Set OutlookApplication = Nothing
Set Nachricht = Nothing
End Sub
 
 
Function test(sPath As String)
    test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()
End Function

Ich lese die Signatur aus dem Standard-Ablagepfad in Form der gespeicherten HTML-Datei aus. Diese wird an das Ende des „HTMLBody“ der E-Mail angehangen.
Mit der Formatierung benötige ich die „SendKeys“-Methode nicht. Dieses wird in einigen Sicherheitsrelevanten Programmen wie Antiviren-Lösungen als problematisch deklariert.

Office 64-Bit: Standard-Einstellung für O365

Im Admin-Center für Office 365 gibt es seit Weihnachten 2018 die folgende Information:

Office ProPlus and Office 2019 will now be installed with 64-bit as the default setting. Previously, the default setting was 32-bit at installation. This change will begin rolling out in mid-January, 2019.

After this change takes place, the 64-bit version of Office will automatically be installed unless you explicitly select the 32-bit version before beginning the installation process.

If you install the 64-bit version, but wanted the 32-bit version instead, you must first uninstall the 64-bit version before installing the 32-bit version. The same is true if you installed the 32-bit version but want to install the 64-bit.

Entsprechend kann es in Zukunft neue Herausforderungen geben. Man sollte vor der Installation prüfen, welche Edition man benötigt. Dafür bietet Microsoft eine wirklich gute Übersicht. Mit dieser kann das aktuelle Einsatzgebiet der Office-Suite übersehen werden. Daraus muss dann jeder einzelne seine Entscheidung auf die Bit-Version treffen.

In der Übersicht der Bit-Versionen stehen auch noch die Office-Version 2016, 2013 sowie 2010 zur Verfügung.

Telefonliste aus Outlook in Excel exportieren

Über Twitter gab es die Anfrage, ob man nicht eine Telefonliste untereinander darstellen könne. Der Standardexport sieht nur den Export eine Kontaktes pro Zeile vor. Leere Felder werden ebenfalls dargestellt.

Anbei der VBA-Code für das Outlook-Makro:

Sub Telefonliste()
On Error Resume Next
 
Const olFolderContacts = 10
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
 
Set colContacts = objNamespace.GetDefaultFolder(olFolderContacts).Items
 
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
Set objWorksheet = objWorkbook.Worksheets(1)
 
objExcel.Cells(1, 1) = "Name"
objExcel.Cells(1, 2) = "Telefonummer"
 
I = 2
 
For Each ObjContact In colContacts
If Not ObjContact.BusinessTelephoneNumber = "" Then
objExcel.Cells(I, 1).Value = ObjContact.FullName
objExcel.Cells(I, 2).Value = ObjContact.BusinessTelephoneNumber
I = I + 1
End If
 
If Not ObjContact.MobileTelephoneNumber = "" Then
objExcel.Cells(I, 1).Value = ObjContact.FullName
objExcel.Cells(I, 2).Value = ObjContact.MobileTelephoneNumber
I = I + 1
End If
 
If Not ObjContact.HomeTelephoneNumber = "" Then
objExcel.Cells(I, 1).Value = ObjContact.FullName
objExcel.Cells(I, 2).Value = ObjContact.HomeTelephoneNumber
I = I + 1
End If
Next
 
Set objRange = objWorksheet.UsedRange
objRange.EntireColumn.Autofit
End Sub

Büronummer, Mobilnummer & private Nummer werden berücksichtigt.

Listen schnell formatieren per Makro in Excel

Häufiger muss ich Auswertung, Listen oder Planungen in Excel lesen. Manche importiere ich auch aus CSV, Text-Dateien oder gar per ODBC-Verbindung. Bei entsprechenden Datenmengen und aufgrund der Übersichtlichkeit formatiere ich mir diese Tabellen gerne. Ich wurde nun gefragt, wie ich dieses entsprechend schnell durchführe und gerne hinterlege ich hier die vba-Zeilen.

Autofilter auf Zeile 1 setzen:

Range("A1").Select
Selection.AutoFilter
Application.ScreenUpdating =&nbsp;True

Zeile 1 fixieren:

    With ActiveWindow
        .FreezePanes = False
        .SplitColumn = 0
        .SplitRow = 1
        .FreezePanes = True
    End With

Zeilen farblich trennen:

Dim z As Integer
    Dim sp As Integer
    Dim s As Integer
 
    sp = Range("IV1").End(xlToLeft).Column + 1
    z = Range("A65536").End(xlUp).Row + 1
 
    With Range("A1", Chr(63 + sp) & 1)
        .Font.Bold = True
        .EntireColumn.AutoFit
        .Interior.ColorIndex = 15
        .Interior.Pattern = xlSolid
    End With
 
    For s = 3 To z - 1 Step 2
    With Range("A" & s, Chr(63 + sp) & s)
     .Interior.ColorIndex = 37
     .Interior.Pattern = xlSolid                                               '
    End With
    Next s

Diese Funktionen nutze ich in einem Makro gemeinsam und entsprechend habe ich mit einem Klick eine schnell formatierte Tabelle.

Umrechnung von Bytes in größere Einheiten

Bei einigen Auswertungen oder Abfragen per Visual Basic oder anderen Skriptsprachen erhält man Datengrößen in Bytes.
Nun werden diese Zahlen zuweilen sehr lang, so dass man diese zur vernünftigen Darstellung umrechnen sollte.
Dabei soll folgende Umrechnungstabelle unterstützen:

  • 1 KiloByte sind 1024 Bytes
  • 1 MegaByte sind 1048576 Bytes
  • 1 GigaByte sind 1073741824 Bytes
  • 1 TerraByte sind 10995116277776 Bytes

Entsprechend mit diesen Angaben können die Werte in die erforderlichen Größeneinheiten umgerechnet werden.

Word-VBA: Rote Schrift per Makro anpassen

Ich habe ein großes Word-Dokument erhalten, welches wichtige Daten in rot gekennzeichnet hat. Da mir für den Ausdruck nur ein Schwarz-Weiß-Drucker zur Verfügung steht, benötige ich ein anderes Unterscheidungsmerkmal.

Als Idee hatte ich nun die roten Zeichen als Unterscheidungsmerkmal in „fett“ und „kursiv“ zu setzen. Da es viele Seiten zu editieren galt, behalf ich mich mit dem folgenden Makro, welches mir die Umsetzung abnahm:

Sub RedChanger
 'Falls das Zeichen die Farbe "Rot" besitzt, folgendes durchführen:
 '- Schrift auf "automatisch" setzen
 '- Schrift auf "fett" setzen
 '- Schrift auf "kursiv" setzen
 
 Dim WordDocument As Word.Document
 Dim longCount As Long
 Set WordDocument = ActiveDocument
 Application.ScreenUpdating = False
 
 For longCount = 1 To WordDocument.Range.Characters.Count
  If WordDocument.Characters(longCount).Font.Color = wdColorRed Then
      WordDocument.Characters(longCount).Font.Color = 0
      WordDocument.Characters(longCount).Font.Bold = True
      WordDocument.Characters(longCount).Font.Italic = True
  End If
  Application.ScreenUpdating = True
 DoEvents
 Next
End Sub

Dieses Skript kann natürlich auch für andere Zwecke erweitert und angepasst werden. Jedes Zeichen wird dabei einzeln analysiert, so dass die Anpassung eines Textes eine gewisse Zeit in Anspruch nimmt.

VBA: LastLogonTimeStamp in Excel-Tabelle

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