Ever since I am working in roles providing technical support for Identity and Access Governance, I am often confronted with the need of printing and archiving a lot of mails for audit trail.
I do despite this task not only because it is annoying but also because there are much better ways for documenting audit proof history than using a document based system.
Anyway ... Since this task is annoying I wrote a little script in VBA to print all selected emails.
This will go into a class called PdfPrinter. It utilizes MS Word in order to print /convert emails to PDF.
Utilizing MS Word is not the best option since the other Application has to be handled properly in order to close Word properly after the job is done. Else you are facing lost references and the application stays open in RAM and the user does not even see it is still running.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Option Explicit
Sub SaveMessageAsPDF()
Dim tmpFileName As Variant
Dim MyDocs As Variant
Dim Selection As Selection
Dim obj As Object
Dim Item As MailItem
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
Set Selection = Application.ActiveExplorer.Selection
For Each obj In Selection
Set Item = obj
Dim FSO As Object
Dim TmpFolder As Object
Dim sName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set tmpFileName = FSO.GetSpecialFolder(2)
sName = Item.Subject
sName = replaceCharsForFileName(sName, "_") & Format(Now, "hh_mm_ss")
tmpFileName = tmpFileName & "\" & sName & ".mht"
Item.SaveAs tmpFileName, olMHTML
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=True)
Dim WshShell As Object
Dim SpecialPath As String
Dim strToSaveAs As String
Set WshShell = CreateObject("WScript.Shell")
MyDocs = WshShell.SpecialFolders(16)
strToSaveAs = MyDocs & "\" & sName & ".pdf"
' check for duplicate filenames
' if matched, add the current time to the file name
If FSO.FileExists(strToSaveAs) Then
sName = sName & Format(Now, "hhmmss")
strToSaveAs = MyDocs & "\" & sName & ".pdf"
End If
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strToSaveAs, _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, _
From:=0, To:=0, Item:= _
wdExportDocumentContent, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
Next obj
wrdDoc.Close
wrdApp.Quit
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set WshShell = Nothing
Set obj = Nothing
Set Selection = Nothing
Set Item = Nothing
End Sub
' This function removes invalid and other characters from file names.
Private Function replaceCharsForFileName(ByVal sName As String, sChr As String) As String
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
sName = Replace(sName, "&", sChr)
sName = Replace(sName, "%", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, " ", sChr)
sName = Replace(sName, "{", sChr)
sName = Replace(sName, "[", sChr)
sName = Replace(sName, "]", sChr)
sName = Replace(sName, "}", sChr)
sName = Replace(sName, "!", sChr)
replaceCharsForFileName = sName
End Function
