Sub Save_Multiple_MSG()
    On Error GoTo Err_Msg
    Dim objItem As Object
    Dim strPrompt As String, strName As String
    Dim sreplace As String, mychar As Variant, strdate As String
    Dim MySelection As Selection
    Dim iCount As Long
    Dim iItem As Long
    Dim strFrom As String
    Dim MyFolder As String
    
    MyFolder = BrowseForFolder
    
    Set MySelection = Outlook.ActiveExplorer.Selection
    For iItem = 1 To MySelection.Count
         
        Set objItem = MySelection.Item(iItem)
         
        If objItem.Class = olMail Then
             
            If objItem.Subject <> vbNullString Then
                strName = objItem.Subject
            Else
                strName = "No Subject"
            End If
            
            strFrom = objItem.SenderName
            sreplace = "-"
             
            For Each mychar In Array("/", "|", "*", "\", ":", "?", Chr(34), "<", ">", "¦")
                strName = Replace(strName, mychar, sreplace)
                strFrom = Replace(strFrom, mychar, sreplace)
            Next mychar
            
            objItem.SaveAs MyFolder & "\" & Format(objItem.ReceivedTime, "yyyy-mm-dd at hh.nn") & "  from  " & strFrom & "  subject  " & strName & ".msg", olMSG
        
        Else
            MsgBox "Item " & iItem & " is not an Email", vbOKOnly, "Error"
        End If
         
    Next iItem
    GoTo exitRoutine
    
Err_Msg:
    MsgBox "Nothing selected or illegal characters in Email", vbOKOnly, "Error"

exitRoutine:
    Set MySelection = Nothing
    Set objItem = Nothing
End Sub

    Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    'Function: Browse for user selected folder. If OpenAt is invalid opens at Desktop
    MyDocsPath = CreateObject("Wscript.Shell").SpecialFolders("Mydocuments")
    OpenAt = MyDocsPath
    'OpenAt = "C:\MyEmailSorting"
    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 [URL="file://\\servername\sharename"]\\servername\sharename[/URL]. 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