Complex outlook email export macro

[marlowwe]

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

[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:


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

[marlowwe]

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

[gmayor]

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

[marlowwe]

You already haP

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

24595




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

[gmayor]

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

[marlowwe]

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 :-)

[marlowwe]

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

[marlowwe]

i Tried this but with error:

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

[gmayor]

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

[marlowwe]

Thank you :hi: