Save selected messages VBA does not save replied messages

[no1levelit]

Hi all,

So please see the VBA code i'm using to save selected messages to a folder of my choice. I noticed that whenever i try to save responded mails, it fails to save as an .eml file and just turns into a blank file (attached image). Please see code below, what am I doing wrong? This is really giving me stress.

Public Sub SaveMessageAsMsg()
'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
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

[gmayor]

You need a different approach for messages you have sent (and more care with declaring variables). I have posted the following previously


Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 20 Mar 2021
Sub SaveSelectedMessagesAsMsg()
'An Outlook macro by Graham Mayor - www.gmayor.com
'Saves the currently selected messages
Dim sPath As String
Dim olItem As MailItem
sPath = BrowseForFolder
If sPath = "" Then
Beep
GoTo lbl_Exit
End If
Do Until Right(sPath, 1) = Chr(92)
sPath = sPath & Chr(92)
Loop
For Each olItem In Application.ActiveExplorer.Selection
If olItem.Class = OlObjectClass.olMail Then
SaveItem olItem, sPath
End If
Next olItem
MsgBox "Message(s) saved", vbInformation
lbl_Exit:
Set olItem = Nothing
Exit Sub
End Sub


Private Sub SaveItem(olItem As MailItem, strPath As String)
'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
If olItem.sender Like "*@gmayor.com" 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(92), "-")
fname = Replace(fname, Chr(124), "-")
On Error GoTo err_Handler
SaveUnique olItem, strPath, fname
lbl_Exit:
Exit Sub
err_Handler:
Err.Clear
GoTo lbl_Exit
End Sub


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" '".txt", olTXT
lbl_Exit:
Exit Function
End Function


Private Function BrowseForFolder() As String
Dim FSO As Object
Set FSO = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose the folder to save the messaage(s)", 0)
On Error Resume Next
BrowseForFolder = FSO.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function