'Save mail with WordEditor as pdf with header
I would like to save a mail body and header just as if it were printed by Outlook or PDFCreator. The sender, cc, bcc , time, to, subject are data that must be in the pdf.
Using this post and others: Print mail item as pdf
I coded this macro that:
- takes the selected mails in Outlook
- makes a new folder in hardcoded folder
- prints with the WordEditor the mail body as PDF
The WordEditor object doesn't save the HEADER of the mailItem. It is important for me to have the information of who sent it, when, the e-mail address, Subject etc.
I want to know how to add the header from the WordEditor object.
Option Explicit
Sub mail_to_pdf_sof()
Dim outApp As Object, objOutlook As Object, objFolder As Object, myItems As Object, myItem As Object, coll As Object, Sel As Object, objInspector As Object, objDoc As Object
Dim psName As String, pdfName As String, strFolderpath As String, Path As String, time_record As String, FileName As String
Dim rol As Integer, indice As Integer, i As Integer
Set outApp = CreateObject("Outlook.Application")
Set objOutlook = outApp.GetNamespace("MAPI")
' PATH TO SAVE PDFs
Path = "F:\"
Path = Path & Format(Date, "yyyy-mm-dd") & " - Mail to PDF" & "\"
On Error Resume Next
MkDir Path
On Error GoTo 0
' GET MAILS SELECTED IN OUTLOOK FOR THE CONVERSION AND SAVE TO PDF
Set coll = New VBA.Collection
If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
coll.Add Application.ActiveInspector.CurrentItem
Else
Set Sel = Application.ActiveExplorer.Selection
For i = 1 To Sel.Count
coll.Add Sel(i)
Next
End If
' SET COUNTERS
rol = 1
indice = 1
time_record = Format(Now, "yyyymmddhhmm")
' SAVE EACH MAIL AS PDF BUT WITHOUT THE HEADER
For Each myItem In coll
' ELIMINATES CHARACTER THAT ARE NOT ALLOWD AND SET A MAX TO FILE NAME LENGTH
FileName = myItem.SenderName & " - " & myItem.Subject
FileName = Replace(FileName, ":", "")
FileName = Replace(FileName, "|", "-")
FileName = Replace(FileName, "/", "-")
FileName = Replace(FileName, "\", "-")
FileName = Replace(FileName, "\\", "-")
FileName = Replace(FileName, Chr(34), "")
If Len(FileName) > 90 Then
FileName = Left(FileName, 90)
End If
' SAVE AS PDF
Set objInspector = myItem.GetInspector
Set objDoc = objInspector.WordEditor
objDoc.ExportAsFixedFormat Path & time_record & " - " & rol & " - " & "Mail - " & FileName & ".pdf", 17
Set objInspector = Nothing
Set objDoc = Nothing
rol = rol + 1
indice = indice + 1
Next myItem
End Sub
Solution 1:[1]
You can get sender, cc, time, to, subject, not bcc, by saving a forwarded version.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub mail_to_pdf_sof()
Dim Path As String
Dim coll As VBA.Collection
Dim Sel As Selection
Dim i As Long
Dim rol As Long
Dim time_record As String
Dim myItem As Object
Dim FileName As String
Dim objInspector As Inspector
Dim objDoc As Object
' PATH TO SAVE PDFs
Path = "F:\"
Path = Path & Format(Date, "yyyy-mm-dd") & " - Mail to PDF" & "\"
On Error Resume Next
MkDir Path
On Error GoTo 0
' GET MAILS SELECTED IN OUTLOOK FOR THE CONVERSION AND SAVE TO PDF
Set coll = New VBA.Collection
If TypeOf ActiveWindow Is Inspector Then
coll.add Application.ActiveInspector.currentItem
Else
Set Sel = ActiveExplorer.Selection
For i = 1 To Sel.count
coll.add Sel(i)
Next
End If
' SET COUNTERS
rol = 1
time_record = Format(Now, "yyyymmddhhmm")
' SAVE EACH MAIL WITH THE HEADER
For Each myItem In coll
' ELIMINATES CHARACTER THAT ARE NOT ALLOWD AND SET A MAX TO FILE NAME LENGTH
FileName = myItem.SenderName & " - " & myItem.Subject
FileName = Replace(FileName, ":", "")
FileName = Replace(FileName, "|", "-")
FileName = Replace(FileName, "/", "-")
FileName = Replace(FileName, "\", "-")
FileName = Replace(FileName, "\\", "-")
FileName = Replace(FileName, Chr(34), "")
If Len(FileName) > 90 Then
FileName = Left(FileName, 90)
End If
'Debug.Print FileName
If myItem.Class = olMail Then
Set myItem = myItem.Forward ' <----
' SAVE AS PDF
Set objInspector = myItem.GetInspector
Set objDoc = objInspector.WordEditor
objDoc.ExportAsFixedFormat Path & time_record & " - " & rol & " - " & _
"Mail - " & FileName & ".pdf", 17
myItem.Close olDiscard
Set objInspector = Nothing
Set objDoc = Nothing
rol = rol + 1
End If
Next myItem
End Sub
Solution 2:[2]
Here is code to extract the internet header from the mail in question. It only took a simple google search outlook vba header information
Option Explicit
Const DRIVE = "F:\"
Const ROOTPATH = "Mail\"
Sub mail_to_pdf_sof()
Dim outApp As Object, objOutlook As Object, objFolder As Object, myItems As Object, myItem As Object, coll As Object, Sel As Object, objInspector As Object, objDoc As Object
Dim psName As String, pdfName As String, strFolderpath As String, Path As String, time_record As String, FileName As String
Dim rol As Integer, indice As Integer, i As Integer
Dim Header As String '*** The header here
Set outApp = CreateObject("Outlook.Application")
Set objOutlook = outApp.GetNamespace("MAPI")
' PATH TO SAVE PDFs
Path = DRIVE & ROOTPATH
Path = Path & Format(Date, "yyyy-mm-dd") & " - Mail to PDF" & "\"
On Error Resume Next
MkDir Path
On Error GoTo -1 ' *** Reset error handling
' GET MAILS SELECTED IN OUTLOOK FOR THE CONVERSION AND SAVE TO PDF
Set coll = New VBA.Collection
If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
coll.Add Application.ActiveInspector.CurrentItem
Else
Set Sel = Application.ActiveExplorer.Selection
For i = 1 To Sel.Count
coll.Add Sel(i)
Next
End If
' SET COUNTERS
rol = 1
indice = 1
time_record = Format(Now, "yyyymmddhhmm")
' SAVE EACH MAIL AS PDF BUT WITHOUT THE HEADER
For Each myItem In coll
' ELIMINATES CHARACTER THAT ARE NOT ALLOWD AND SET A MAX TO FILE NAME LENGTH
FileName = myItem.SenderName & " - " & myItem.subject
FileName = Replace(FileName, ":", "")
FileName = Replace(FileName, "|", "-")
FileName = Replace(FileName, "/", "-")
FileName = Replace(FileName, "\", "-")
FileName = Replace(FileName, "\\", "-")
FileName = Replace(FileName, Chr(34), "")
If Len(FileName) > 90 Then
FileName = Left(FileName, 90)
End If
'*
'* Get the header for this mail into the string Header
'* Do whatever you want with it
'* (merge it with the mail or save as a separate file)
'*
Header = GetInetHeaders(myItem)
' SAVE AS PDF
Set objInspector = myItem.GetInspector
Set objDoc = objInspector.WordEditor
objDoc.ExportAsFixedFormat Path & time_record & " - " & rol & " - " & "Mail - " & FileName & ".pdf", 17
Set objInspector = Nothing
Set objDoc = Nothing
rol = rol + 1
indice = indice + 1
Next myItem
End Sub
'*********************************************************************************
'* Get the header from the mailitem
'* https://www.slipstick.com/developer/code-samples/outlooks-internet-headers
'*
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
' Purpose: Returns the internet headers of a message.'
' Written: 4/28/2009'
' Author: BlueDevilFan'
' //techniclee.wordpress.com/
' Outlook: 2007'
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function
Solution 3:[3]
David Rowie wrote: Option Explicit dont change anything to my question
Without Option Explicit your code compiles. However with Option explicit you get a compile error:
Please add Option Explicit and correct all compile errors first of all.
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 | niton |
| Solution 2 | StureS |
| Solution 3 | StureS |