Saving Multiple Selected Emails As MSG Files In Bulk In Outlook

[climbp19981]

Hi all. I am trying to figure out a VBA code for saving multiple selected emails with the the subject :"date" & "time" & "original subject".

I am using this code.

Public Sub SaveMessageAsMsg()
Dim xMail As Outlook.MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xDtDate As Date
Dim xName, xFileName As String
On Error Resume Next
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
If Not TypeName(xFolder) = "Nothing" Then
Set xFolderItem = xFolder.self
xFileName = xFolderItem.Path & ""
Else
xFileName = ""
Exit Sub
End If
For Each xObjItem In Outlook.ActiveExplorer.Selection
If xObjItem.Class = olMail Then
Set xMail = xObjItem
xName = xMail.Subject
xDtDate = xMail.ReceivedTime
xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(xDtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & xName & ".msg"
xPath = xFileName + xName
xMail.SaveAs xPath, olMSG
End If
Next
End Sub



The problem is that window does not allow file name with "","/",":","*","?",""","<",">" and "|"
So, the above code does not apply to subject with those symbol.
How can I replace those symbol with blank to save my email messages? :banghead::banghead:

[skatonni]

There are multiple method available for example.


Option Explicit

Public Sub SaveMessageAsMsg()

Dim xShell As Object
Dim xFolder As Object
Dim strStartingFolder As String
Dim xFolderItem As Object

Dim xMail As MailItem
Dim xObjItem As Object

Dim xPath As String
Dim xFileName As String
Dim xName As String
Dim xDtDate As Date

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

For Each xObjItem In ActiveExplorer.Selection

If xObjItem.Class = olmail Then

Set xMail = xObjItem

xName = CleanFileName(xMail.Subject)
Debug.Print xName

xDtDate = xMail.ReceivedTime

xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(xDtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & xName & ".msg"

xPath = xFileName & xName

xMail.SaveAs xPath, olMsg
End If
Next

End Sub

Public Function CleanFileName(strFileName As String) As String

' http://windowssecrets.com/forums/showthread.php/60041-Invalid-Charaters-(VBA)

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

[climbp19981]

Thank you so much, it is very helpful for me.
However, I encounter another problem.
If the subject is too long, the code will be failed to save to email. Is there any way to cut the excess words? :bow:

[gmayor]

You can use the Left function to limit the number of characters e.g.

change
xName = CleanFileName(xMail.Subject)to
xName = Left(CleanFileName(xMail.Subject),100)