Export An Outlook Email To PDF File

[Xokiru]

Hello,

I have this VBA in outlook which is exporting email to PDF format, but there is an issue. If there is image or table in the letter, it does not fit into the PDF page. Maybe someone has an idea how it could be fit? Maybe there is an option to set boundaries? or at least maybe it is possible to change page format to Landscape?

Private Sub Independent()

    Dim Selection As Selection
    Dim obj As Object
    Dim Item As MailItem
    Dim Answer As String
    Dim QuestionToMessageBox As String
    
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    Set Selection = Application.ActiveExplorer.Selection


    Dim val As String
        val = TextBox1.Text
    If StrPtr(val) = 0 Then
        MsgBox "Filename cannot be empty!"
            Exit Sub
    ElseIf Len(val) > 260 Then MsgBox "You typed in too many character, max 260!"
            Exit Sub
                End If
    Unload Me
    
For Each obj In Selection
 
    Set Item = obj
    
    Dim FSO As Object, TmpFolder As Object
    Dim sName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set tmpFileName = FSO.GetSpecialFolder(2)
    
    sName = val
    ReplaceChars sName, "-"
    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
    MyDocs = ""
       
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:=True, 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 obj = Nothing
    Set Selection = Nothing
    Set Item = Nothing
    
End Sub

Thank you for your help!

 

[Worf]

Hello

The example below changes the orientation to landscape and resizes tables; tell me if images will also need resizing.

' Outlook UserForm module
Private Sub Independent()
Dim ToSaveAs$, p$, Sel As Selection, obj As Object, Item As MailItem, _
Answer$, fn, val$, FSO As Object, sName$, tbl As Word.Table
Dim wrdApp As Word.Application, wrdDoc As Document
Set wrdApp = CreateObject("Word.Application")
Set Sel = Application.ActiveExplorer.Selection
val = TextBox1.Text
If StrPtr(val) = 0 Then
    MsgBox "Filename cannot be empty!"
    Exit Sub
ElseIf Len(val) > 260 Then MsgBox "You typed in too many characters, max 260!"
    Exit Sub
End If
Unload Me
For Each obj In Sel
    Set Item = obj
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fn = FSO.GetSpecialFolder(2)
    sName = val
    fn = fn & "\" & sName & ".mht"
    Item.SaveAs fn, olMHTML
    Set wrdDoc = wrdApp.Documents.Open(FileName:=fn, Visible:=True)
    p = "c:\accounts\"
    ToSaveAs = p & sName & ".pdf"
    ' check for duplicate filenames, if matched, add the current time to file name
    If FSO.FileExists(ToSaveAs) Then
        sName = sName & Format(Now, "hhmmss")
        ToSaveAs = p & sName & ".pdf"
    End If
    wrdApp.ActiveDocument.PageSetup.Orientation = wdOrientLandscape
    For Each tbl In wrdApp.ActiveDocument.Tables
        tbl.PreferredWidthType = wdPreferredWidthPercent
        tbl.PreferredWidth = 80
    Next
    wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
    ToSaveAs, ExportFormat:=wdExportFormatPDF, _
    OpenAfterExport:=True, OptimizeFor:=wdExportOptimizeForPrint, _
    Range:=wdExportAllDocument, From:=0, To:=0, Item:= _
    wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
    CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
    BitmapMissingFonts:=True, UseISO19005_1:=False
    MsgBox "exported", 64, ToSaveAs
Next
wrdDoc.Close
wrdApp.Quit
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set obj = Nothing
Set Sel = Nothing
Set Item = Nothing
End Sub


Private Sub UserForm_Click()
Independent
End Sub