VBA Outlook save mail with wordEditor as pdf WITH HEADER

0
votes

I would like to make an outlook macro to save a mail body and HEADER just as if it were printed out 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
  • print with the wordeditor the body mail as PDF

My issue is that the wordEditor objecto doesn't save the HEADER of the mailItem. It is important for me because I have the information o fwho 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

I wonder if anyone knows a sensible solution to this problem, thanks!

3
vbaemailpdfoutlook
Where is Option Explicit? Also read Minimal, Complete, and Verifiable example: stackoverflow.com/help/mcve – StureS
I"m a begginer at coding. It is VBA, it is easly understandable. Copy and paste it and it works. If anyone knew the subject that i"m asking for, he or she certainly knows the problem i"m exposing, because it is really common. Option Explicit dont change anything to my question – David_Rowie

3 Answers

1
votes

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
1
votes

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
0
votes

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:

Path is not defined

Please add Option Explicit and correct all compile errors first of all.