Consulting

Results 1 to 7 of 7

Thread: Complex outlook email export macro

  1. #1
    VBAX Newbie
    Joined
    Dec 2016
    Posts
    4
    Location

    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 ?


    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

  2. #2
    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:

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Newbie
    Joined
    Dec 2016
    Posts
    4
    Location
    Quote Originally Posted by gmayor View Post
    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:

    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

  4. #4
    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

    CreateFolders strSavePath    'add this line to save the message as msg format
        SaveUnique olItem, strSavePath, strFileName
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    VBAX Newbie
    Joined
    Dec 2016
    Posts
    4
    Location
    Quote Originally Posted by gmayor View Post
    You already haP
    I added a code show below but this error showed and no exported mails:

    screenshot.png

    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

    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

  6. #6
    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).

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    VBAX Newbie
    Joined
    Dec 2016
    Posts
    4
    Location
    Quote Originally Posted by gmayor View Post
    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 :-)
    Last edited by marlowwe; 07-17-2019 at 04:06 AM.

Posting Permissions

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