Consulting

Results 1 to 8 of 8

Thread: Outlook VBA code to convert attachments to pdf and save in a folder

  1. #1

    Outlook VBA code to convert attachments to pdf and save in a folder

    Hi Guys

    I am looking for outlook VBA code so that when the user selects multiple emails in his folder and run the macro then it should do the following:

    1. If its word document then convert that to PDF and save it down in a shared folder.
    2. If the attachment is PDF already then save it down in the same format in a shared folder.
    3. If there is a message in the email body then save it down separately in PDF file in shared folder.

    All the PDF files should be named automatically using the sendername/Date/subject line etc...

    Is this achievable?

    Thanks

  2. #2
    The below code will convert email message to PDF . I need the code now to save attachments in Word format to PDF in a folder . Can anyone please help me in this?
    Sub SaveEmailMessages()
    
    
    Dim objOL As Object, MyOlSelection As Outlook.Selection
    Dim MyOlNamespace As Outlook.NameSpace
    Set MyOlNamespace = Application.GetNamespace("MAPI")
    Set MyOlSelection = Application.ActiveExplorer.Selection
    
    
    Call SaveAsPDFfile(MyOlSelection)
    
    
    Set MyOlSelection = Nothing
    Set objOL = Nothing
    End Sub
    Sub SaveAsPDFfile(pobjSelection As Outlook.Selection)
    
    
    Dim objOL As Object, MyOlSelection As Outlook.Selection
    Dim xMail As Outlook.MailItem
    On Error Resume Next
    
    
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
    ' Get the collection of selected objects.
    Set MyOlSelection = pobjSelection
    
    
        Dim StrSaveFilename As String
        'Make sure at least one item is selected
        If MyOlSelection.Count = 0 Then
           Response = MsgBox("Please select an email", vbExclamation, "Save as PDF")
           Exit Sub
        End If
    ' Now loop through all selected emails
    For Each xMail In MyOlSelection
        'Get all selected items
        'Retrieve the selected item
        'Set MySelectedItem = MyOlSelection.Item(1)
        
        'Get the user's TempFolder to store the item in
        Dim fso As Object, TmpFolder As Object
        Set fso = CreateObject("scripting.filesystemobject")
        Set tmpFileName = fso.GetSpecialFolder(2)
        
        'construct the filename for the temp mht-file
        strName = "www_howto-outlook_com"
        tmpFileName = tmpFileName & "\" & strName & ".mht"
        
        'Save the mht-file
        xMail.SaveAs tmpFileName, olMHTML
        
        'Create a Word object
        Dim wrdApp As Word.Application
        Dim wrdDoc As Word.Document
        Set wrdApp = CreateObject("Word.Application")
        
        'Open the mht-file in Word without Word visible
        Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False)
        
        'Define the SafeAs dialog
        Dim dlgSaveAs As FileDialog
        Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)
        
        'Determine the FilterIndex for saving as a pdf-file
        'Get all the filters
        Dim fdfs As FileDialogFilters
        Dim fdf As FileDialogFilter
        Set fdfs = dlgSaveAs.Filters
    
    
        'Loop through the Filters and exit when "pdf" is found
        Dim I As Integer
        I = 0
        For Each fdf In fdfs
            I = I + 1
            If InStr(1, fdf.Extensions, "pdf", vbTextCompare) > 0 Then
                Exit For
            End If
        Next fdf
        
        'Set the FilterIndex to pdf-files
        dlgSaveAs.FilterIndex = I
        
        'Get location of My Documents folder
        Dim WshShell As Object
        Dim SpecialPath As String
        Set WshShell = CreateObject("WScript.Shell")
        SpecialPath = WshShell.SpecialFolders(16)
        
        'Construct a safe file name from the message subject
        Dim msgFileName As String
        
        msgFileName = xMail.Subject
    
    
        Set oRegEx = CreateObject("vbscript.regexp")
        oRegEx.Global = True
        oRegEx.Pattern = "[\/:*?""<>|]"
        msgFileName = Trim(oRegEx.Replace(msgFileName, ""))
        
        'Set the initial location and file name for SaveAs dialog
        Dim strCurrentFile As String
      '  dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName
        StrSaveFilename = Trim(oRegEx.Replace(xMail.Subject, ""))
        StrSaveFilename = Left(StrSaveFilename, 50)
        StrSaveFilename = StrSaveFilename & Format(Time(), "hh-mm-ss") & ".pdf"
        dlgSaveAs.InitialFileName = "U:\Aman\Martin Oulook\Word\" & StrSaveFilename
        'xMail.SaveAsFile "U:\Aman\Martin Oulook\Word\" & StrSaveFilename
        
        'Show the SaveAs dialog and save the message as pdf
        If dlgSaveAs.Show = -1 Then
            strCurrentFile = dlgSaveAs.SelectedItems(1)
            
            'Verify if pdf is selected
            If Right(strCurrentFile, 4) <> ".pdf" Then
                Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _
                    vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel)
                    If Response = vbCancel Then
                        wrdDoc.Close
                        wrdApp.Quit
                        Exit Sub
                    ElseIf Response = vbOK Then
                        intPos = InStrRev(strCurrentFile, ".")
                        If intPos > 0 Then
                           strCurrentFile = Left(strCurrentFile, intPos - 1)
                        End If
    
    
                        strCurrentFile = strCurrentFile & ".pdf"
                    End If
            End If
            
            'Save as pdf
            wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
            strCurrentFile, 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
        
        End If
        Set dlgSaveAs = Nothing
        
        ' close the document and Word
        wrdDoc.Close
        wrdApp.Quit
        xMail.Categories = ""
        xMail.FlagStatus = olFlagComplete
        xMail.UnRead = False
        xMail.Save
    Next
        'Cleanup
        Set MyOlNamespace = Nothing
        Set MyOlSelection = Nothing
        Set MySelectedItem = Nothing
        Set wrdDoc = Nothing
        Set wrdApp = Nothing
        Set oRegEx = Nothing
    
    
    End Sub

  3. #3
    The following based on code I have posted before will save both the message and the word docx (or PDF) attachments with unique names in the named folder (which it will create if not present). I'll let you modify it to your own file naming preferences.

    Option Explicit
    Const strSaveFldr As String = "C:\Path\Attachments\"
    Private wdApp As Object
    Private wdDoc As Object
    
    Sub ProcessMessage()
    'An Outlook macro by Graham Mayor
    Dim olMsg As Object
        'On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.item(1)
        SaveAttachments olMsg
    lbl_Exit:
        Exit Sub
    End Sub
    
    Sub ProcessFolder()
    'An Outlook macro by Graham Mayor
    Dim olNS As Outlook.NameSpace
    Dim olMailFolder As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olMailItem As Object
        On Error GoTo Err_Handler
        Set olNS = GetNamespace("MAPI")
        Set olMailFolder = olNS.PickFolder
        Set olItems = olMailFolder.Items
        For Each olMailItem In olItems
            SaveAttachments olMailItem
            DoEvents
        Next olMailItem
    Err_Handler:
        Set olNS = Nothing
        Set olMailFolder = Nothing
        Set olItems = Nothing
        Set olMailItem = Nothing
    lbl_Exit:
        Exit Sub
    End Sub
    
    Private Sub SaveAttachments(olItem As Object)
    'Graham Mayor - http://www.gmayor.com - Last updated - 09 Oct 2018
    Dim olAttach As Attachment
    Dim strFName As String
    Dim strExt As String
    Dim j As Long
    Dim olInsp As Inspector
    Dim oRng As Object
    Dim strTemp As String
    Dim intPos As Integer
        strTemp = Environ("TEMP") & "\"
        
        If Not TypeName(olItem) = "MailItem" Then GoTo lbl_Exit
        
        CreateFolders strSaveFldr
    
        SaveAsPDFfile olItem
    
        If olItem.Attachments.Count > 0 Then
            For j = 1 To olItem.Attachments.Count
                Set olAttach = olItem.Attachments(j)
                Select Case LCase(Mid(olAttach.fileName, InStrRev(olAttach.fileName, Chr(46))))
                    Case ".docx", ".doc"
                        On Error Resume Next
                        olAttach.SaveAsFile strTemp & olAttach.fileName
                        Set wdApp = GetObject(, "Word.Application")
                        If Err Then
                            Set wdApp = CreateObject("Word.Application")
                        End If
                        On Error GoTo 0
                        wdApp.Visible = True
                        Set wdDoc = wdApp.Documents.Open(strTemp & olAttach.fileName)
                        intPos = InStrRev(olAttach.fileName, ".")
                        strFName = Left(olAttach.fileName, intPos - 1)
                        strFName = strFName & ".pdf"
                        strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
                        strFName = FileNameUnique(strSaveFldr, strFName, strExt)
                        wdDoc.ExportAsFixedFormat OutputFilename:=strSaveFldr & strFName, _
                                                  ExportFormat:=17, _
                                                  OpenAfterExport:=False, _
                                                  OptimizeFor:=0, _
                                                  Range:=0, _
                                                  From:=0, _
                                                  To:=0, _
                                                  item:=0, _
                                                  IncludeDocProps:=True, _
                                                  KeepIRM:=True, _
                                                  CreateBookmarks:=0, _
                                                  DocStructureTags:=True, _
                                                  BitmapMissingFonts:=True, _
                                                  UseISO19005_1:=False
                        wdDoc.Close 0
                        'If bWordWasNotRunning = True Then wdApp.Quit
                    Case ".pdf"
                        strFName = olAttach.fileName
                        strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
                        strFName = FileNameUnique(strSaveFldr, strFName, strExt)
                        olAttach.SaveAsFile strSaveFldr & strFName
                    Case Else
                End Select
            Next j
            olItem.Save
        End If
    lbl_Exit:
        Set olAttach = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub
    
    Private Sub SaveAsPDFfile(olItem As Object)
    Dim olNS As NameSpace
    Dim tmpPath As String
    Dim strFileName As String
    Dim strName As String
    Dim oRegex As Object
    
        On Error Resume Next
        Set wdApp = GetObject(, "Word.Application")
        If Err Then
            Set wdApp = CreateObject("Word.Application")
        End If
        On Error GoTo 0
    
        Set olNS = Application.GetNamespace("MAPI")
    
        'Get the user's TempFolder to store the temporary file
        tmpPath = Environ("TEMP")
    
        'construct the filename for the temp mht-file
        strName = "email_temp.mht"
        tmpPath = tmpPath & "\" & strName
    
        'Save temporary file
        olItem.SaveAs tmpPath, 10
    
        'Open the temporary file in Word
        Set wdDoc = wdApp.Documents.Open(fileName:=tmpPath, _
                                         AddToRecentFiles:=False, _
                                         Visible:=False, _
                                         Format:=7)
    
        'Create a file name from the message subject
        strFileName = olItem.Subject
        'Remove illegal filename characters
        Set oRegex = CreateObject("vbscript.regexp")
        oRegex.Global = True
        oRegex.Pattern = "[\/:*?""<>|]"
        strFileName = Trim(oRegex.Replace(strFileName, "")) & ".pdf"
        strFileName = FileNameUnique(strSaveFldr, strFileName, "pdf")
        strFileName = strSaveFldr & strFileName
        wdDoc.ExportAsFixedFormat OutputFilename:= _
                                  strFileName, _
                                  ExportFormat:=17, _
                                  OpenAfterExport:=False, _
                                  OptimizeFor:=0, _
                                  Range:=0, _
                                  From:=0, _
                                  To:=0, _
                                  item:=0, _
                                  IncludeDocProps:=True, _
                                  KeepIRM:=True, _
                                  CreateBookmarks:=0, _
                                  DocStructureTags:=True, _
                                  BitmapMissingFonts:=True, _
                                  UseISO19005_1:=False
    
        ' close the document
        wdDoc.Close 0
    lbl_Exit:
        'Cleanup
        Set olNS = Nothing
        Set wdDoc = Nothing
        Set oRegex = Nothing
        Exit Sub
    End Sub
    
    Private Function FileNameUnique(strPath As String, _
                                    strFileName As String, _
                                    strExtension As String) As String
    'An Outlook macro by Graham Mayor
    Dim lngF As Long
    Dim lngName As Long
        lngF = 1
        lngName = Len(strFileName) - (Len(strExtension) + 1)
        strFileName = Left(strFileName, lngName)
        Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        FileNameUnique = strFileName & Chr(46) & strExtension
    lbl_Exit:
        Exit Function
    End Function
    
    Private Function FileExists(strName As String) As Boolean
    'An Outlook macro by Graham Mayor
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FileExists(strName) Then
            FileExists = True
        Else
            FileExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
    
    Private Function FolderExists(strFolder As String) As Boolean
    'An Outlook macro by Graham Mayor
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If (FSO.FolderExists(strFolder)) Then
            FolderExists = True
        Else
            FolderExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
    
    Private Function CreateFolders(strPath As String)
    'An Outlook macro by Graham Mayor
    Dim strTempPath As String
    Dim lngPath As Long
    Dim VPath As Variant
        VPath = Split(strPath, "\")
        strPath = VPath(0) & "\"
        For lngPath = 1 To UBound(VPath)
            strPath = strPath & VPath(lngPath) & "\"
            If Not FolderExists(strPath) Then MkDir strPath
        Next lngPath
    lbl_Exit:
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word)
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  4. #4
    Thanks so much Graham. How can we amend the code so that it will look into the active folder and only the selected emails will be saved down in PDF format in a folder? Thanks
    Last edited by Derek_123; 10-10-2018 at 02:30 AM.

  5. #5
    Use the following macro to call the process

    Sub ProcessSelection()
    Dim olMailItem As Object
        'An Outlook macro by Graham Mayor
        If Application.ActiveExplorer.Selection.Count = 0 Then
            MsgBox "No Items selected!", vbCritical, "Error"
            Exit Sub
        End If
        On Error Resume Next
        For Each olMailItem In Application.ActiveExplorer.Selection
            If TypeName(olMailItem) = "MailItem" Then
                SaveAttachments olMailItem
            End If
            DoEvents
        Next olMailItem
    Err_Handler:
        Set olMailItem = Nothing
    lbl_Exit:
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word)
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  6. #6
    Thanks Graham. I keep on getting an error "Outlook can not save this file because it's already open elsewhere(email_temp.mht).

  7. #7
    It should have been closed by the command
    wdDoc.Close 0
    If it hasn't it suggests that you had a crash somewhere and the lock file is still present for email_temp.mht
    Take a look in the Temp folder (put %TEMP% in the address window of File Explorer to shortcut to the folder) and ensure you begin with email_temp.mht and its lock file deleted.
    Graham Mayor - MS MVP (Word)
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  8. #8
    Thanks Graham , The code worked great . You are a star

Posting Permissions

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