How to SaveAs with Subject in file name? - vba

I'm trying to save to hard drive all the mails in my Outlook folders.
'==========================================
' Save Inbox Mail Items To The File System
'==========================================
Sub saveInboxMailItemsToFileSystem()
' Set variables
Dim ns As Outlook.NameSpace
Dim inbox As Outlook.MAPIFolder
Dim item As Outlook.MailItem
Dim strFileName As String
' Set namespace
Set ns = Application.GetNamespace("MAPI")
' Get inbox folder
Set inbox = ns.GetDefaultFolder(olFolderInbox)
' Loop through all mail items
For Each item In inbox.Items
' Set filename
strFileName = "C:\Users\<moi>\SvgMail\" & VBA.Format(item.ReceivedTime, "yyyymmdd", vbUseSystemDayOfWeek) & " - " & item.Subject & ".msg"
' Save mail item to file system
item.SaveAs strFileName, Outlook.OlSaveAsType.olMSG
Next item
End Sub
I get the following error:
Erreur d'exécution '-2147286788 (800300fc)': Echec de l'opération.

You need to make sure that the result file name (strFileName) is valid and contains only allowed symbols. Try to save any file using the problematic name and you will be notified that some symbols are not allowed. But in our case the Outlook object model doesn't give you meaningful answers, it just notifies you about a problem. You, as a developer, should analyze such cases and fix the problem. For example, if you try to search for the error code you may find a similar thread - Outlook Email Archiving Macro Doesnt work if subject has asterisk. For example, you may find a sample function which replaces some characters for using in the SaveAs call:
Function FixFileName(FileName As String) As String
Dim fname As String
fname = Trim(FileName)
fname = Replace(fname, " ", "_")
fname = Replace(fname, ",", "")
fname = Replace(fname, "'", "")
fname = Replace(fname, "(", "")
fname = Replace(fname, ")", "")
fname = Replace(fname, "~", "")
fname = Replace(fname, "*", "")
fname = Replace(fname, "?", "")
fname = Replace(fname, "/", "")
fname = Replace(fname, "\", "")
fname = Replace(fname, """", "")
FixFileName = fname
End Function

Related

Saving outlook emails in folders and subfolder to local drive and preserve original directory error

I used below code to save outlook emails in folders and subfolder to local drive and preserve original directory.
Private objFileSystem As Object
Private Sub ExportFolderWithAllItems()
Dim objFolder As Outlook.Folder
Dim strPath As String
'Specify the local folder where to save the emails
strPath = "C:\Users\qiaoqiao\"
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
'Select a Outlook PST file or Outlook folder
Set objFolder = Outlook.Application.Session.PickFolder
Call ProcessFolders(objFolder, strPath)
MsgBox "Email saving is completed", vbExclamation
End Sub
Private Sub ProcessFolders(objCurrentFolder As Outlook.Folder, strCurrentPath As String)
Dim objItem As Object
Dim strSubject, strFileName, strFilePath As String
Dim objSubfolder As Outlook.Folder
'Create local folder based on Outlook mailbox folder directory
strCurrentPath = strCurrentPath & ModifyName(objCurrentFolder.Name)
objFileSystem.CreateFolder strCurrentPath
For Each objItem In objCurrentFolder.Items
strSubject = ModifyName(objItem.Subject)
strFileName = strSubject & ".msg"
strFilePath = strCurrentPath & "\" & strFileName
i = 0
Do Until False
strFilePath = strCurrentPath & "\" & strFileName
'Check if there exist emails with the same subject
If objFileSystem.FileExists(strFilePath) Then
'Add order number to the end of the subject
i = i + 1
strFileName = strSubject & " (" & i & ").msg"
Else
Exit Do
End If
Loop
'Save as MSG file
'On Error Resume Next
'Debug.Print Len(strFilePath)
objItem.SaveAs strFilePath, olMSG
Next
'Process subfolders recursively
If objCurrentFolder.Folders.Count > 0 Then
For Each objSubfolder In objCurrentFolder.Folders
Call ProcessFolders(objSubfolder, strCurrentPath & "\")
Next
End If
End Sub
Function ModifyName(folderName As String) As String
'Dim folderName As String
'In order to save emails in the same directory as in Outlook,
'when creating the folders in local drive,
'the folder name must not contain some special characters
folderName = Replace(folderName, ":", "")
folderName = Replace(folderName, "|", "")
folderName = Replace(folderName, ",", "")
folderName = Replace(folderName, "'", "")
folderName = Replace(folderName, "(", "")
folderName = Replace(folderName, ")", "")
folderName = Replace(folderName, "~", "")
folderName = Replace(folderName, "*", "")
folderName = Replace(folderName, "?", "")
folderName = Replace(folderName, "/", "")
folderName = Replace(folderName, "\", "")
folderName = Replace(folderName, """", "")
folderName = Trim(folderName)
'folderName = Replace(folderName, Chr(34), "")
ModifyName = folderName
End Function
However, since there are many layers of folders, so the strFilePath become very long, and it gave me a runtime error saying Operation failed.
Can anyone please advise me how to solve this issue? thank you in advance!!!
In Office products there is a limit to the number of characters in the file path. This error message occurs when you save or open a file if the path to the file (including the file name) exceeds 218 characters. This limitation includes three characters representing the drive, the characters in folder names, the backslash character between folders, and the characters in the file name.
Make sure that the path to the file contains fewer than 219 characters. To do this, use one of the following methods:
Rename the file so that it has a shorter name.
Rename one or more folders that contain the file so that they have shorter names.
Move the file to a folder with a shorter path name.
Note that if you enter 255 characters in the File Name box in the
Save As dialog box, and click OK, you will receive the following error message:
The path you entered, "<path>", is too long. Enter a shorter path.
Also, if you attempt to save a file and the path exceeds 255 characters, you will receive the following error message:
The file could not be accessed. Try one of the following:
- Make sure the specified folder exists.
- Make sure the folder that contains the file is not read-only.
- Make sure the file name does not contain any of the following characters: < > ? [ ] : | *.
- Make sure the file/path name doesn't contain more than 218 characters.

Excel VBA loop through emails in inbox folders and save messages to local address [duplicate]

This question already has an answer here:
How to SaveAs with Subject in file name?
(1 answer)
Closed 3 months ago.
I was trying to use VBA to loop through all the subfolders of my inbox(Some subfolders contain emails, while some do not), and then save all the emails to a folder on my computer.
The macro was able to save some emails in the subfolders, but not all. And then the macro stopped at one subfolder and gave an error message "Runtime error '-2147287037(80030003)':The operation failed'.
Can anyone please help me understand what was wrong? Thank you!
Below is my code.
Sub Savemails()
Application.ScreenUpdating = False
Dim olApp As Outlook.Application
Dim olNameSpace As Outlook.Namespace
Dim olFolder As Object
Dim savePath As String
Dim user_mail As String
Dim Folder As Outlook.MAPIFolder
Dim mItem As Object
Application.DisplayAlerts = False
user_mail = ThisWorkbook.Worksheets("Sheet1").Range("EmailAddress").Value
Set olApp = New Outlook.Application
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.Folders(user_mail).Folders("inbox")
savePath = "C:\Users\yangrach\Desktop\emails\2022\"
For Each Folder In olFolder.Folders
For Each mItem In Folder.Items
If mItem.Class = OlObjectClass.olMail Then
mItem.SaveAs savePath & mItem.Subject & ".msg"
End If
Next mItem
Next Folder
Application.ScreenUpdating = True
End Sub
First of all, you need to make sure that you deal with a valid file path, see What characters are forbidden in Windows and Linux directory names? for more information. The Subject property may contain forbidden symbols, so you may try using the following function to fix the file path and make sure the file name and path is valid:
Function FixFileName(FileName As String) As String
Dim fname As String
fname = Trim(FileName)
fname = Replace(fname, " ", "_")
fname = Replace(fname, ",", "")
fname = Replace(fname, "'", "")
fname = Replace(fname, "(", "")
fname = Replace(fname, ")", "")
fname = Replace(fname, "~", "")
fname = Replace(fname, "*", "")
fname = Replace(fname, "?", "")
fname = Replace(fname, "/", "")
fname = Replace(fname, "\", "")
fname = Replace(fname, """", "" )
FixFileName = fname
End Function

Save emails as text by rule, preventing text wrapping

I have VBA code, in a rule, that saves emails as individual text files as they arrive.
The problem is that text within the .txt files begins to wrap at a certain distance down the .txt file, eventually becoming a single character per row.
This does not happen if I open the email individually, and then use the File>Save As command to save it as a .txt file (no wrapping at all).
As far as I can tell, this may be happening because the rule runs automatically and does not open the email first.
Is there a way to save the text file without text wrapping?
Alternately, I think a solution would be a macro to:
Open email on screen when it is received
Save the email as a .txt file
Close the email on screen
The current macro (taken from Slipstick I think):
Sub ExportEmailBodyToTXT(myMail As Outlook.MailItem)
Dim strFolder As String
Dim strSubject As String
Dim strFile As String
'Change the path to the specific Windows folder
strFolder = "C:\Users\madmanmick\Desktop\Folder_X"
If myMail.Subject <> "" Then
'Remove unsupported characters in subject
strSubject = myMail.Subject
strSubject = Replace(strSubject, "/", " ")
strSubject = Replace(strSubject, "\", " ")
strSubject = Replace(strSubject, ":", "")
strSubject = Replace(strSubject, "?", " ")
strSubject = Replace(strSubject, Chr(34), " ")
strdate = Format(myMail.ReceivedTime, "yyyy mm dd ")
strFile = strFolder & "\" & strdate & myMail.Subject & ".txt"
myMail.SaveAs strFile, OLTXT
End If
End Sub

save email from outlook to local drive using vba

i am trying to save a selected mail from outlook to a folder dynamically created with mail's subject name. The code ran successfully for one mail. if i select different mail and try to run the macro it is showing path not found error. My code is below:
Public Sub OpslaanMails()
Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Set OlApp = CreateObject("Outlook.Application")
Dim fName, sName As String
Dim oMail As Outlook.MailItem
fName = "F:\Test\inwards\"
Set oMail = OlApp.ActiveExplorer.Selection.Item(1)
sName = oMail.Subject
makeSelectionDir (sName)
sPath = fName & "\" & sName & "\"
oMail.SaveAs sPath & sName & ".msg", olMsg
For Each oAttach In oMail.Attachments
oAttach.SaveAsFile sPath & oAttach.FileName
Set oAttach = Nothing
Next
End Sub
Sub makeSelectionDir(sName As String)
Dim fName, sPath As String
fName = "F:\Test\inwards\"
sPath = fName & sName
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(sName) Then .CreateFolder sPath 'error is in this line
End With
End Sub
Make sure sName does not contain any characters illegal in a file name, such as ":".
I used your idea and changed two or three things to make it more robust.
Put this in a module in Outlook VBA Editor and run, having selected an email.
I also added the time and date at the beginning of the folder and email file names.
I left the part about saving file attachements but know that they are already embedded in the .msg file.
Const ILLEGAL_CHARACTERS = Array("*", "/", "\", "?", """", "<", ">", ":", "|")
Sub SaveEmailToFile()
Dim oMail As MailItem
Dim sPath As String
Dim sObj As String
Dim oAttach As Attachment
'Select email and process subject
If ActiveExplorer.Selection.Count = 0 Then
MsgBox "No emails are selected."
Exit Sub
End If
Set oMail = ActiveExplorer.Selection.Item(1)
With oMail
sObj = oMail.Subject
'Remove illegal characters from email subject
If sObj = "" Then
sObj = "No Object"
Else
For Each s In ILLEGAL_CHARACTERS
sObj = Replace(sObj, s, "")
Next s
End If
'Get date and time string from email received timestamp
dateStr = Year(.ReceivedTime) & "_" & _
Month(.ReceivedTime) & "_" & _
Day(.ReceivedTime) & " " & _
Hour(.ReceivedTime) & " " & _
Minute(.ReceivedTime) & " " & _
Second(.ReceivedTime) & " "
End With
sPath = "C:\Someplace\" & dateStr & sObj & "\"
'Create folder
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(sPath) Then .CreateFolder sPath
End With
'Save email and attachements
oMail.SaveAs sPath & oMail.Subject & ".msg", olMSG
For Each oAttach In oMail.Attachments
oAttach.SaveAsFile sPath & oAttach.FileName
Next oAttach
End Sub
I could only recreate the error
path not found
if fName was not valid.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Public Sub OpslaanMails()
Dim fName As String
Dim sName As String
Dim sPath As String
Dim oMail As MailItem
Dim oAttach As Attachment
fName = "F:\Test\inwards\"
Debug.Print "fName: " & fName
Set oMail = ActiveExplorer.Selection.Item(1)
sName = oMail.subject
Debug.Print "sName: " & sName
' Double slash accepted by Windows but not by some programmers
'If Right(fName, 1) = "\" Then
' fName = Left(fName, Len(fName) - 1)
' Debug.Print
' Debug.Print "fName: " & fName
'End If
' Double slash after fName preferable to no slash
sPath = fName & "\" & sName & "\"
Debug.Print "sPath: " & sPath
makeSelectionDir fName, sPath
' Possible illegal characters in sName not addressed.
' Do not test with replies nor forwards,
' the : in the subject is not a legal character.
oMail.SaveAs sPath & sName & ".msg", olMsg
For Each oAttach In oMail.Attachments
oAttach.SaveAsFile sPath & oAttach.FileName
Set oAttach = Nothing
Next
End Sub
Sub makeSelectionDir(fName As String, sPath As String)
With CreateObject("Scripting.FileSystemObject")
' Test for fName
' Otherwise there is file not found error in the create
If .FolderExists(fName) Then
' if subfolder does not exist create it
If Not .FolderExists(sPath) Then
.createFolder sPath
End If
Else
Debug.Print
Debug.Print "Folder " & fName & " does not exist."
'MsgBox "Folder " & fName & " does not exist."
End
End If
End With
End Sub
Inconsistency of sName vs sPath has been addressed in
If Not .FolderExists(sName) Then .CreateFolder sPath

Save mail with subject as filename

Good morning all,
I am hoping someone can help me here with a piece of coding.
I am looking to save the selected email to a specific directory, with the name of the email, and of course as a .msg file.
This is what i have today, and it is not working. It saves a file but the name only has the first 2 characters (looks like it errors after the semi colon file name eg: FW or RE)... the content of the file is blank and the filetype has not been applied.
'code to save selected email
Dim selectedEmail As MailItem
Set selectedEmail = ActiveExplorer.Selection.Item(1)
Dim emailsub As String
emailsub = ActiveExplorer.Selection.Item(1).Subject
With selectedEmail
.SaveAs "C:\direcotry\folder\" & emailsub & ".msg", olMSG
End With
Thank you in anticipation.
Dom
The reason is very simple. You email subject contains and Invalid Character. For example : This usually happens when the email is a RE: or FWD:
Try this
Sub Sample()
Dim selectedEmail As MailItem
Dim emailsub As String
Set selectedEmail = ActiveExplorer.Selection.Item(1)
emailsub = GetValidName(selectedEmail.subject)
'Debug.Print emailsub
With selectedEmail
.SaveAs "C:\direcotry\folder\" & emailsub & ".msg", OlSaveAsType.olMSG
End With
End Sub
Function GetValidName(sSub As String) As String
'~~> File Name cannot have these \ / : * ? " < > |
Dim sTemp As String
sTemp = sSub
sTemp = Replace(sTemp, "\", "")
sTemp = Replace(sTemp, "/", "")
sTemp = Replace(sTemp, ":", "")
sTemp = Replace(sTemp, "*", "")
sTemp = Replace(sTemp, """", "")
sTemp = Replace(sTemp, "<", "")
sTemp = Replace(sTemp, ">", "")
sTemp = Replace(sTemp, "|", "")
GetValidName = sTemp
End Function