Complex outlook email export macro

Hey Guys,


can you hepl me with macro below ?


I found macro somwhere on the internet, it is possible to upgrade it with foloowing function ?

• open "Save as window" like when you Save As Excel file
• The macro create sub-folder in the picked location from previous step. Folder name: yyyymmdd hh.mm senders name - mail subject
• Open this subfolder and save Outlook msg file (already do this macro below)
• Save email to PDF file
• Save all email attachements

It is possible to upgrade this awesome macro ?

Code:

---

Option Explicit


Sub SaveMessage()
'An Outlook macro by Graham Mayor - www.gmayor.com
'Saves the currently selected message
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveItem olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub


Sub SaveAllMessagesInFolder()
'An Outlook macro by Graham Mayor - www.gmayor.com
'Saves all the messages in a selected Outlook folder
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
    Set olItems = Session.PickFolder.Items
    For Each olItem In olItems
        SaveItem olItem
    Next olItem
    Set olItem = Nothing
    Set olItems = Nothing
lbl_Exit:
    Exit Sub
End Sub




Private Sub SaveItem(olItem As MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
'The main macro called by the above macros.
'This macro can be used as a script to save the messages as they arrive
'provided you change fPath = to a fixed path, so you are not prompted each time a message arrives
Dim fName As String
Dim fPath As String
    fPath = InputBox("Enter the path to save the message." & vbCr & _
                    "The path will be created if it doesn't exist.", _
                    "Save Message", "C:\!Outlook saved mails\")
    CreateFolders fPath


    If olItem.Sender Like "*** Email address is removed for privacy ***" Then    'Your domain
        fName = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    Else
        fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    End If
    fName = Replace(fName, Chr(58) & Chr(41), "")
    fName = Replace(fName, Chr(58) & Chr(40), "")
    fName = Replace(fName, Chr(34), "-")
    fName = Replace(fName, Chr(42), "-")
    fName = Replace(fName, Chr(47), "-")
    fName = Replace(fName, Chr(58), "-")
    fName = Replace(fName, Chr(60), "-")
    fName = Replace(fName, Chr(62), "-")
    fName = Replace(fName, Chr(63), "-")
    fName = Replace(fName, Chr(124), "-")
    SaveUnique olItem, fPath, fName
lbl_Exit:
    Exit Sub
End Sub


Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
'Creates the full path 'strPath' if missing or incomplete
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not oFSO.FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function


Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
'Ensures that filenames are not overwritten
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    lngF = 1
    lngName = Len(strFileName)
    Do While fso.FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function

---

The short answer is no. It requires a different technique to save a message as PDF and frankly there is not a lot of point selecting the folder for each save (and the dialog in question is not in any case available from Outlook). It is better to fix the root folder in code and then you can create sub folders to provide the pattern you specified on the fly. The following will save the messages as PDF in a sub folder of that named folder as requested and also save any attachments in that same folder:

Code:

---

Option Explicit

Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean
Private strSavePath As String
Private strName As String
Const strPath As String = "D:\Path\Email Messages\" 'The root folder


Sub SaveSelectedMessagesAsPDF()
'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
'Select the messages to process and run this macro
Dim olMsg As Object
Dim strFname As String, strExt As String
Dim j As Long
    'Create the folder to store the messages if not present
    If CreateFolders(strPath) = False Then GoTo lbl_Exit
    'Open or Create a Word object
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
        bStarted = True
    End If
    On Error GoTo 0
    For Each olMsg In Application.ActiveExplorer.Selection
        SaveAsPDFfile olMsg
    Next olMsg
    MsgBox "Completed"
lbl_Exit:
    If bStarted Then wdApp.Quit
    Set olMsg = Nothing
    Set wdApp = Nothing
    Exit Sub
End Sub


Private Sub SaveAsPDFfile(olItem As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
Dim olNS As NameSpace
Dim fso As Object, TmpFolder As Object
Dim tmpPath As String
Dim strFileName As String
Dim oRegex As Object


    Set olNS = Application.GetNamespace("MAPI")


    'Get the user's TempFolder to store the temporary file
    Set fso = CreateObject("Scripting.FileSystemObject")
    tmpPath = fso.GetSpecialFolder(2)


    '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 = Format(olItem.ReceivedTime, "yyyymmdd hh.mm") & "-" & olItem.SenderName & "-" & olItem.Subject
    'Remove illegal filename characters
    Set oRegex = CreateObject("vbscript.regexp")
    oRegex.Global = True
    oRegex.Pattern = "[\/:*?""<>|]"
    strFileName = Trim(oRegex.Replace(strFileName, ""))
    strSavePath = strPath & strFileName
    CreateFolders strSavePath
    strFileName = strFileName & ".pdf"
    strFileName = FileNameUnique(strSavePath, strFileName, "pdf")
    strFileName = strSavePath & strFileName


    'Save the attachments
    SaveAttachments olItem, strSavePath


    'Save As pdf
    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 olItem = Nothing
    Set wdDoc = Nothing
    Set oRegex = Nothing
    Exit Sub
End Sub


Private Sub SaveAttachments(olItem As MailItem, strSaveFldr As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 26 May 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long


    On Error Resume Next
    If olItem.Attachments.Count > 0 Then
        For j = 1 To olItem.Attachments.Count
            Set olAttach = olItem.Attachments(j)
            strFname = olAttach.fileName
            strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
            strFname = FileNameUnique(strSaveFldr, strFname, strExt)
            olAttach.SaveAsFile strSaveFldr & strFname
        Next j
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub




Private Function CreateFolders(strPath As String) As Boolean
'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
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) & "\"
        On Error GoTo Err_Handler
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
    CreateFolders = True
lbl_Exit:
    Exit Function
Err_Handler:
    MsgBox "The path " & strPath & " is invalid!"
    CreateFolders = False
    Resume lbl_Exit
End Function


Private Function FileNameUnique(strPath As String, _
                                strFileName As String, _
                                strExtension As String) As String
'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
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 FolderExists(fldr) As Boolean
'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If (fso.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Set fso = Nothing
    Exit Function
End Function


Private Function FileExists(filespec) As Boolean
'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Set fso = Nothing
    Exit Function
End Function

---

Quote:

---

Originally Posted by gmayor

The short answer is no. It requires a different technique to save a message as PDF and frankly there is not a lot of point selecting the folder for each save (and the dialog in question is not in any case available from Outlook). It is better to fix the root folder in code and then you can create sub folders to provide the pattern you specified on the fly. The following will save the messages as PDF in a sub folder of that named folder as requested and also save any attachments in that same folder:

Code:

---

Option Explicit

Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean
Private strSavePath As String
Private strName As String
Const strPath As String = "D:\Path\Email Messages\" 'The root folder


Sub SaveSelectedMessagesAsPDF()
'Graha
lbl_Exit:
    Set fso = Nothing
    Exit Function
End Function

---

---

Wow man, its amazing :-)

How to add macro for saveMeaasge as msg file in the same subfolder?

Thank youuuuuuuuuuu

You already have the SaveUnique function from the previous macro. Add that function to the module and insert the line as indicated in the SaveAsPDFFile sub after the CreateFolders strSavePath line

Code:

---

CreateFolders strSavePath    'add this line to save the message as msg format
    SaveUnique olItem, strSavePath, strFileName

---

Quote:

---

Originally Posted by gmayor

You already haP

---

I added a code show below but this error showed and no exported mails:

Attachment 24595

Code:

---


Private Sub SaveAsPDFfile(olItem As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
Dim olNS As NameSpace
Dim fso As Object, TmpFolder As Object
Dim tmpPath As String
Dim strFileName As String
Dim oRegex As Object

    Set olNS = Application.GetNamespace("MAPI")

    'Get the user's TempFolder to store the temporary file
    Set fso = CreateObject("Scripting.FileSystemObject")
    tmpPath = fso.GetSpecialFolder(2)

    'construct the filename for the temp mht-file
    strName = "email_temp1.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 = Format(olItem.ReceivedTime, "yyyymmdd hh.mm") & "-" & olItem.SenderName & "-" & olItem.Subject
    'Remove illegal filename characters
    Set oRegex = CreateObject("vbscript.regexp")
    oRegex.Global = True
    oRegex.Pattern = "[\/:*?""<>|]"
    strFileName = Trim(oRegex.Replace(strFileName, ""))
    strSavePath = strPath & strFileName
    CreateFolders strSavePath
    strFileName = strFileName & ".pdf"
    strFileName = FileNameUnique(strSavePath, strFileName, "pdf")
    strFileName = strSavePath & strFileName

    'Save message as msg
    CreateFolders strSavePath    'add this line to save the message as msg format
    SaveUnique olItem, strSavePath, strFileName

    'Save As pdf
    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 olItem = Nothing
    Set wdDoc = Nothing
    Set oRegex = Nothing
    Exit Sub
End Sub


....

---

and this

Code:

---

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
'Ensures that filenames are not overwritten
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    lngF = 1
    lngName = Len(strFileName)
    Do While fso.FileExists(strSavePath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strSavePath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function

---

You should have added the line where I indicated, not added both lines, as that simply screws things up. The CreateFolders line was already present.
It seems you have now crashed Word and it is running as a background task with the temporary file open. You might be able to open Word and close the file or you can force Word closed using Task Manager (or reboot).

Code:

---

Private Sub SaveAsPDFfile(olItem As MailItem)'Graham Mayor - https://www.gmayor.com - Last updated - 15 Jul 2019
Dim olNS As NameSpace
Dim fso As Object, TmpFolder As Object
Dim tmpPath As String
Dim strFileName As String
Dim oRegex As Object


    Set olNS = Application.GetNamespace("MAPI")


    'Get the user's TempFolder to store the temporary file
    Set fso = CreateObject("Scripting.FileSystemObject")
    tmpPath = fso.GetSpecialFolder(2)


    'construct the filename for the temp mht-file
    strName = "email_temp1.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 = Format(olItem.ReceivedTime, "yyyymmdd hh.mm") & "-" & olItem.SenderName & "-" & olItem.Subject
    'Remove illegal filename characters
    Set oRegex = CreateObject("vbscript.regexp")
    oRegex.Global = True
    oRegex.Pattern = "[\/:*?""<>|]"
    strFileName = Trim(oRegex.Replace(strFileName, ""))
    strSavePath = strPath & strFileName
    CreateFolders strSavePath
    'add this line to save the message as msg format
    SaveUnique olItem, strSavePath, strFileName


    strFileName = strFileName & ".pdf"
    strFileName = FileNameUnique(strSavePath, strFileName, "pdf")
    strFileName = strSavePath & strFileName


    'Save As pdf
    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 olItem = Nothing
    Set wdDoc = Nothing
    Set oRegex = Nothing
    Exit Sub
End Sub

---

Quote:

---

Originally Posted by gmayor

You should have ad..

---

Thank you, but this feature generate a lots of trouble.

Could you please update macro with no extraction to pdf ? do the same thing but only - extract attachements and save email as msg file ? with selection to save like "save As" ?

I relly appriciate your work :-)

Quote:

---

Originally Posted by gmayor

You should have added the Set oRegex = Nothing
Exit Sub
End Sub
[/CODE]

---

Could you please help me to downgrade the macro above and exclude the save as pdf file ? (the big problem with Word app running in background)

Thank you.

Vojtech

i Tried this but with error:

Code:

---

Option Explicit

Sub SaveMSGandATTACHEMENTS()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
   
    ' ============================== save function start =========================
    Dim xShell As Object
    Dim xFolder As Object
    Dim strStartingFolder As String
    Dim xFolderItem As Object
    Dim xFileName As String
    Dim objOL As Outlook.Application
   
    Set xShell = CreateObject("Shell.Application")


    On Error Resume Next
    ' Bypass error when xFolder is nothing on Cancel
    Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
    ' Remove error bypass as soon as the purpose is served
    On Error GoTo 0
   
    If Not TypeName(xFolder) = "Nothing" Then
        Set xFolderItem = xFolder.self
        xFileName = xFolderItem.Path
        ' missing path separator
        If Right(xFileName, 1) <> "\" Then xFileName = xFileName & "\"
    Else
        xFileName = ""
        Exit Sub
    End If
    ' ============================== save function end =========================
   
    SaveAttachments olMsg
    SaveMessageAsMsg olMsg
lbl_Exit:
    Exit Sub
End Sub




Public Sub SaveAttachments(olItem As MailItem)
'Graham Mayor -
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long, lng_Index As Long
Dim arrInvalid() As String
Dim xFileName As String


    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
    On Error Resume Next
    If olItem.Attachments.Count > 0 Then
        For j = 1 To olItem.Attachments.Count
            Set olAttach = olItem.Attachments(j)
            'If Not olAttach.fileName Like "image*.*" Then
            strFname = olItem.Subject & "_" & olAttach.FileName
            For lng_Index = 0 To UBound(arrInvalid)
                strFname = Replace(strFname, Chr(arrInvalid(lng_Index)), Chr(95))
            Next lng_Index
            strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
            strFname = FileNameUnique(xFileName, strFname, strExt)
            olAttach.SaveAsFile xFileName & strFname
            'End If
        Next j
        olItem.Save
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub
Public Sub SaveMessageAsMsg(olItem As MailItem)
'Update by Extendoffice 2018/3/5
Dim xMail As Outlook.MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xDtDate As Date
Dim xName, xFileName As String
Dim xSender As String
Dim xFileName As String


           
On Error Resume Next
For Each xObjItem In Outlook.ActiveExplorer.Selection
    If xObjItem.Class = olMail Then
        Set xMail = xObjItem
        xName = Left(CleanFileName(xMail.Subject), 40)
        xSender = CleanFileName(xMail.senderName)
        xDtDate = xMail.ReceivedTime
        xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
              vbUseSystem) & Format(xDtDate, "-hhnn", _
              vbUseSystemDayOfWeek, vbUseSystem) & "-" & xSender & "-" & xName & ".msg"
        xPath = xFileName + xName
        xMail.SaveAs xPath, olMsg
    End If
Next
End Sub


Private Function FileNameUnique(strPath As String, _
                                strFileName As String, _
                                strExtension As String) As String
'Graham Mayor - https://www.gmayor.com - Last updated - 22 Jul 2019
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
    lngF = 1
    Set fso = CreateObject("Scripting.FileSystemObject")
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While fso.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Set fso = Nothing
    Exit Function
End Function


Public Function CleanFileName(strFileName As String) As String


   
    Dim Invalids
    Dim e
    Dim strTemp As String
   
    Invalids = Array("?", "*", ":", "|", "<", ">", "[", "]", """", "/")
   
    strTemp = strFileName
   
    For Each e In Invalids
        strTemp = Replace(strTemp, e, " ")
        'strTemp = Replace(strTemp, e, "")
    Next
   
    CleanFileName = strTemp
   
End Function
Private Function CreateFolders(strPath As String) As Boolean
'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) & "\"
        On Error GoTo Err_Handler
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
    CreateFolders = True
lbl_Exit:
    Exit Function
Err_Handler:
    MsgBox "The path " & strPath & " is invalid!"
    CreateFolders = False
    Resume lbl_Exit
End Function

---

If you don't want the PDF comment out the line wdDoc.ExportAsFixedFormat in my original code.

Thank you :hi: