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