I honestly was passed down some of the code in this script so I am not sure who to give the original credit too!
I modified it to include both emails and meeting requests and error out if neither is acceptable. Added another cleanse group, saved the file in the following format (Project# SenderName DateTimeReceived Subject.msg)
If the senders name was not available (which is the case in some situations) it pulls the last 11 characters and creates a string to save it to when referenced.
Default save folder is C:\
If anyone can find the original poster please leave a comment below!
Enjoy!
Sub MASS_SAVE()
Dim Mitem
Dim prompt As String
Dim name As String
Dim Nname As String
Dim Exp As Outlook.Explorer
Dim sln As Outlook.Selection
Dim saveSubject As String
Dim senderName As String
Dim senderCheck As String
Dim msg As Object
Dim timeSent As String
Set Exp = Application.ActiveExplorer
Set sln = Exp.Selection
If sln.count = 0 Then
MsgBox "No objects selected."
Else
myPath = BrowseForFolder("C:\")
Set Mitem = Outlook.ActiveExplorer.Selection.Item(1)
Nname = InputBox("Please enter in the Project #")
For Each Mitem In sln
If TypeName(Mitem) = "ReportItem" Or TypeName(Mitem) = "MailItem" Or TypeName(Mitem) = "MeetingItem" Then
saveSubject = Mitem.Subject
If Nname = "" Then
name = Mitem.Subject
Else
name = Nname
End If
' Cleanse illegal characters from subject... :/|*?<>" etc or sharepoint wont have it!
name = Replace(name, "<", "(")
name = Replace(name, ">", ")")
name = Replace(name, "&", "n")
name = Replace(name, "%", "pct")
name = Replace(name, """", "'")
name = Replace(name, "´", "'")
name = Replace(name, "`", "'")
name = Replace(name, "{", "(")
name = Replace(name, "[", "(")
name = Replace(name, "]", ")")
name = Replace(name, "}", ")")
name = Replace(name, " ", "_")
name = Replace(name, " ", "_")
name = Replace(name, " ", "_")
name = Replace(name, "..", "_")
name = Replace(name, ".", "_")
name = Replace(name, "__", "_")
name = Replace(name, ": ", "_")
name = Replace(name, ":", "_")
name = Replace(name, "/", "_")
name = Replace(name, "\", "_")
name = Replace(name, "*", "_")
name = Replace(name, "?", "_")
name = Replace(name, """", "_")
name = Replace(name, "__", "_")
name = Replace(name, "|", "_")
saveSubject = Replace(saveSubject, "<", "(")
saveSubject = Replace(saveSubject, ">", ")")
saveSubject = Replace(saveSubject, "&", "n")
saveSubject = Replace(saveSubject, "%", "pct")
saveSubject = Replace(saveSubject, """", "'")
saveSubject = Replace(saveSubject, "´", "'")
saveSubject = Replace(saveSubject, "`", "'")
saveSubject = Replace(saveSubject, "{", "(")
saveSubject = Replace(saveSubject, "[", "(")
saveSubject = Replace(saveSubject, "]", ")")
saveSubject = Replace(saveSubject, "}", ")")
saveSubject = Replace(saveSubject, " ", "_")
saveSubject = Replace(saveSubject, " ", "_")
saveSubject = Replace(saveSubject, " ", "_")
saveSubject = Replace(saveSubject, "..", "_")
saveSubject = Replace(saveSubject, ".", "_")
saveSubject = Replace(saveSubject, "__", "_")
saveSubject = Replace(saveSubject, ": ", "_")
saveSubject = Replace(saveSubject, ":", "_")
saveSubject = Replace(saveSubject, "/", "_")
saveSubject = Replace(saveSubject, "\", "_")
saveSubject = Replace(saveSubject, "*", "_")
saveSubject = Replace(saveSubject, "?", "_")
saveSubject = Replace(saveSubject, """", "_")
saveSubject = Replace(saveSubject, "__", "_")
saveSubject = Replace(saveSubject, "|", "_")
If TypeName(Mitem) = "MailItem" Then
senderCheck = "/O=EXCHANGE"
senderName = Mitem.sender
timeSent = Mitem.ReceivedTime
If Left$(senderName, 11) = senderCheck Then
senderName = Right$(Mitem.sender, 11)
Else
senderName = Mitem.sender
End If
ElseIf TypeName(Mitem) = "MeetingItem" Then
senderCheck = "/O=EXCHANGE"
senderName = Mitem.senderName
timeSent = Mitem.ReceivedTime
If Left$(senderName, 11) = senderCheck Then
senderName = Right$(Mitem.sender, 11)
Else
senderName = Mitem.senderName
End If
ElseIf TypeName(Mitem) = "ReportItem" Then
senderName = "Read Receipt"
timeSent = Mitem.CreationTime
Else
MsgBox "Unknown mail type....ERROR"
'senderName = ""
'MsgBox senderName, vbCritical, "Sender Name"
'variable111 = Mitem.CreationTime
'MsgBox variable111, vbApplicationModal, "Creation Time"
End If
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
Mitem.SaveAs myPath & "\" & "Project#" & name & " " & Left$(senderName, 20) & " " & Format(timeSent, "MM-DD-YY HHMM") & " " & Left$(saveSubject, 40) & ".msg", olMSG
End If
Else
MsgBox "A message was not saved because it does not match an EMail format."
End If
Next Mitem
End If
MsgBox "Export Complete!", vbOKOnly, "Export Status"
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function To Browse for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
