Export An Outlook Email To PDF File

Thanks Thanks:  0
Likes Likes:  0
Results 1 to 2 of 2

Thread: Export An Outlook Email To PDF File

  1. #1
    New Member
    Join Date
    Nov 2016
    Posts
    1
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Post Export An Outlook Email To PDF File

     
    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?

    Code:
    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!

  2. #2
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,101
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Export An Outlook Email To PDF File

      
    Hello

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


    Code:
    ' 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
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

 

 
DMCA.com