Outlook将多个选定的邮件批量保存为.msg文件

本文在参考了网络上其他博主的博客之后，结合自己的实际使用心得，在其他博主代码的基础上改进了VBA代码，提供给有需要批量保存Outlook邮件的读者使用，具体使用步骤如下：

1、打开Outlook桌面程序并登录自己的邮箱，选择需要另存为本地msg文件的电子邮件（可Ctrl + Shift多选），随后同时按住Alt + F11按键打开“Microsoft Visual Basic Applications”窗口；

2、在“Microsoft Visual Basic Applications”窗口中，鼠标左键点击“插入”>“模块”，然后将下面的VBA代码复制到“模块”窗口中：

Function GetPureName(filename As String)
Dim i As Integer
    Dim s, RstStr As String
    Dim Bol As Boolean
    For i = 1 To Len(filename)
    s = Mid(filename, i, 1)
    If (s Like "[0-9 a-z A-Z]") Then
    RstStr = RstStr & s
    End If
Next i
    GetPureName = RstStr
End Function
Public Sub SaveMessageAsMsg()
Dim xMail As Outlook.MailItem
Dim xMeet As Outlook.MeetingItem
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 = GetPureName(xMail.Subject)
        xDtDate = xMail.ReceivedTime
        xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
          vbUseSystem) & Format(xDtDate, "-hhnnss", _
          vbUseSystemDayOfWeek, vbUseSystem) & "-" & xObjItem.Subject & ".msg"
        xName = Replace(xName, ":", "")
        xName = Replace(xName, "：", "")
        xName = Replace(xName, "&", "")
        xName = Replace(xName, "/", "")
        xName = Replace(xName, "“", "")
        xName = Replace(xName, "”", "")
        xName = Replace(xName, Chr(34), "")
        xName = Replace(xName, "?", "")
        xName = Replace(xName, "？", "")
        xName = Replace(xName, ">", "")
        xName = Replace(xName, "<", "")
        xName = Replace(xName, "!", "")
        xName = Replace(xName, "|", "")
        xName = Replace(xName, "！", "")
        xName = Replace(xName, "|", "")
        xName = Replace(xName, "   ", "")
        xName = Replace(xName, "#", "")
        xPath = xFileName + xName
        Debug.Print xName
        Debug.Print xPath
        Debug.Print xObjItem.Subject
        xMail.SaveAs xPath, olMSG
    End If
    
    If xObjItem.Class <> olMail Then
        Set xMeet = xObjItem
        xName = GetPureName(xMeet.Subject)
        xDtDate = xMeet.ReceivedTime
        xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
          vbUseSystem) & Format(xDtDate, "-hhnnss", _
          vbUseSystemDayOfWeek, vbUseSystem) & "-" & xObjItem.Subject & ".msg"
        xName = Replace(xName, ":", "")
        xName = Replace(xName, "：", "")
        xName = Replace(xName, "&", "")
        xName = Replace(xName, "/", "")
        xName = Replace(xName, "“", "")
        xName = Replace(xName, "”", "")
        xName = Replace(xName, Chr(34), "")
        xName = Replace(xName, "?", "")
        xName = Replace(xName, "？", "")
        xName = Replace(xName, ">", "")
        xName = Replace(xName, "<", "")
        xName = Replace(xName, "!", "")
        xName = Replace(xName, "|", "")
        xName = Replace(xName, "！", "")
        xName = Replace(xName, "|", "")
        xName = Replace(xName, "   ", "")
        xName = Replace(xName, "#", "")
        xPath = xFileName + xName
        Debug.Print xName
        Debug.Print xPath
        Debug.Print xObjItem.Subject
        xMeet.SaveAs xPath, olMSG
    End If
    
Next

    Dim objSelection As Outlook.Selection
    Set objSelection = Application.ActiveExplorer.Selection
    MsgBox "Number of selected items: " & _
                objSelection.Count, vbInformation, "Selected Items"
                
End Sub

3、在“ Microsoft Visual Basic Applications ”窗口中，鼠标左键点击“运行”>“运行子过程/用户窗体”（或直接按F5键），在弹出的名为”宏“窗口中选择宏后点击运行，运行VBA代码；

4、在弹出的”Browse For Folder“窗口中选择你需要保存的邮件的文件夹路径，点击OK，等待邮件批量保存，邮件保存时，鼠标光标会一直转圈，此时耐心等待所选择邮件全部保存完毕即可；

5、邮件保存完毕时，会弹出如下对话框，提示你所选择保存的邮件的数量，点击OK即可，至此邮件保存完毕，可前往相应文件夹路径下检查一下所选邮件是否全都备份成功了，最后关闭“ Microsoft Visual Basic Applications ”窗口。

（本文参考文章：如何在Outlook中将多个选定的电子邮件批量保存为MSG文件？）