Another Macros Script for saving tons of emails into a standardize format

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