【Office】Outlook 批量导出多个邮件的附件

系统：Win10
Outlook：Microsoft Office 2016

1.需求描述

最近有个同事收到了 50 多封邮件，每个邮件基本带一个附件，问我有没有办法帮忙批量处理，我马上想到用 VBA 来进行批量处理，然后上网搜了一下解决办法，这里将实现步骤记录下来。

2.实现步骤

打开 Outlook 的选项，进入信任中心，打开信任中心设置，点击宏设置后选中启用所有宏点确定保存（等会记得改回去）

在收件箱上右键选择 新建文件夹，命名为：For Download

选中所有要导出附件的邮件后，右键点击 移动 选刚刚新建的 For Download 文件夹

完成后可以打开该文件夹看看邮件是否已经移过去

接着按 Alt+F11 调出 VBA编辑器（这里如果无法弹出编辑器，可以参照评论区小伙伴的意见：进入选项 → 自定义功能区 → 勾选开发工具），双击 ThisOutlookSession，然后在弹出窗口粘贴如下代码，然后点击运行按钮

Function FileFolderExists(strFullPath As String) As Boolean     '---判断文件夹是否存在
   If Not Dir(strFullPath, 16) = vbNullString Then
       FileFolderExists = True
   Else
       FileFolderExists = False
   End If
End Function
Function CreateParentFile(strPath As String) As String          '---创建存放所有附件的父文件夹
    While FileFolderExists(strPath) = True
        strPath = strPath + CStr(Timer())
        CreateParentFile (strPath)
    Wend
    CreateParentFile = strPath
End Function
Sub SaveTheAttachment()                                         '---主函数，用于保存右键附件
    Dim olApp As New Outlook.Application
    Dim nmsName As Outlook.NameSpace
    Dim vItem As Object
    Dim path As String          '---文件夹名称
    Dim result As Integer       '---点击弹窗结果
    
    Set nmsName = olApp.GetNamespace("MAPI")
    Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
    Set fldFolder = myFolder.Folders("For Download")    '---如果邮件在别的文件夹，只需要改这里就行
    
    path = CreateParentFile("D:\Attachment")            '---如果想换个存放附件的文件夹名称，改这里即可
    VBA.MkDir (path)            '---创建父文件夹，用于存放所有文件
        
    For Each vItem In fldFolder.Items
       '-----Save Attachment-------
        For Each att In vItem.Attachments
            att.SaveAsFile path & "\" & att.FileName
        Next
        '------Save Attachment--------
    Next
   
    Set fldFolder = Nothing
    Set nmsName = Nothing
    
    '------下载完成--------
    result = MsgBox("附件已下载完成，请至目标文件夹查看！", 0 + 64 + 0, "下载成功") '---提示下载完成
    Select Case result
    Case 1
    Shell "explorer.exe " & path, vbNormalFocus '---打开输出文件夹
    End Select
    '------下载完成--------
End Sub

我们点击弹窗的确定按钮，就可以打开保存附件的 Attachment 文件夹，这里可以发现附件已经下载下来了

最后记得：删除代码，关闭窗口，将宏设置还原

3.功能升级

根据评论区反馈，对之前的功能做了一些升级

升级功能：

• 1.获取每个邮件的主题并创建文件夹（如果存在特殊字符，直接删除），然后将附件保存到其中
• 2.自动创建文件夹
• 3.结束后自动打开文件夹

实现代码：

Const SpecialCharacters As String = "\/:*?<>|"                  '---不能用于创建文件夹的特殊字符

Function ReplaceSpecialCharacters(myString As String) As String '---去字符串中除特殊字符的函数
    Dim newString As String, L As Long, i As Long
    Dim char As Variant
    
    newString = myString
    L = Len(newString)
    
    For i = 1 To L
        char = Mid(newString, i, 1)
        If InStr(SpecialCharacters, char) > 0 Then
            newString = Replace(newString, char, "")            '---碰到特殊字符直接删除
        End If
    Next i
    
    ReplaceSpecialCharacters = newString
End Function

Function FileFolderExists(strFullPath As String) As Boolean     '---判断文件夹是否存在
   If Not Dir(strFullPath, 16) = vbNullString Then
       FileFolderExists = True
   Else
       FileFolderExists = False
   End If
End Function

Function CreateParentFile(strPath As String) As String          '---创建存放所有附件的父文件夹
    While FileFolderExists(strPath) = True
        strPath = strPath + CStr(Timer())
        CreateParentFile (strPath)
    Wend
    CreateParentFile = strPath
End Function

Sub SaveTheAttachment()                                         '---主函数，用于保存右键附件
    Dim olApp As New Outlook.Application
    Dim nmsName As Outlook.NameSpace
    Dim vItem As Object
    Dim sbj As String           '---邮件主题
    Dim path As String          '---文件夹名称
    Dim filepath As String      '---文件路径
    Dim result As Integer       '---点击弹窗结果
    
    Set nmsName = olApp.GetNamespace("MAPI")
    Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
    Set fldFolder = myFolder.Folders("For Download")    '---如果邮件在别的文件夹，只需要改这里就行
    
    path = CreateParentFile("D:\Attachment")            '---如果想换个存放附件的文件夹名称，改这里即可
    VBA.MkDir (path)            '---创建父文件夹，用于存放所有文件
        
    For Each vItem In fldFolder.Items
        sbj = vItem.Subject     '---获取邮件主题
        filepath = path + "\" + ReplaceSpecialCharacters(sbj)
        'Debug.Print filepath    '---打印输出文件夹路径
        On Error Resume Next    '---遇到异常直接跳过
        VBA.MkDir (filepath)    '---创建以主题命名的文件夹
        '-----Save Attachment-------
        For Each att In vItem.Attachments
            att.SaveAsFile filepath & "\" & att.FileName
        Next
        '------Save Attachment--------
    Next
   
    Set fldFolder = Nothing
    Set nmsName = Nothing
    
    '------下载完成--------
    result = MsgBox("附件已下载完成，请至目标文件夹查看！", 0 + 64 + 0, "下载成功") '---提示下载完成
    Select Case result
    Case 1
    Shell "explorer.exe " & path, vbNormalFocus '---打开输出文件夹
    End Select
    '------下载完成--------
End Sub

最后记得：删除代码，关闭窗口，将宏设置还原

4.处理问题

4.1 特殊字符处理

增加函数去除主题内的 特殊字符，因为包含特殊字符，无法创建对应文件夹，如下图所示

Const SpecialCharacters As String = "\/:*?<>|"                  '---不能用于创建文件夹的特殊字符

Function ReplaceSpecialCharacters(myString As String) As String '---去字符串中除特殊字符的函数
    Dim newString As String, L As Long, i As Long
    Dim char As Variant
    
    newString = myString
    L = Len(newString)
    
    For i = 1 To L
        char = Mid(newString, i, 1)
        If InStr(SpecialCharacters, char) > 0 Then
            newString = Replace(newString, char, "")            '---碰到特殊字符直接删除
        End If
    Next i
    
    ReplaceSpecialCharacters = newString
End Function

4.2 文件夹自动创建

修复Attachment文件夹已存在的问题，现在不需要创建该文件夹，直接运行代码即可，如果存在相同文件夹，则在文件夹后面加个当天毫秒值

Function FileFolderExists(strFullPath As String) As Boolean     '---判断文件夹是否存在
   If Not Dir(strFullPath, 16) = vbNullString Then
       FileFolderExists = True
   Else
       FileFolderExists = False
   End If
End Function
Function CreateParentFile(strPath As String) As String          '---创建存放所有附件的父文件夹
    While FileFolderExists(strPath) = True
        strPath = strPath + CStr(Timer())
        CreateParentFile (strPath)
    Wend
    CreateParentFile = strPath
End Function

4.3 下载完成后提示

代码结尾加了个 弹框提示，不然不知道时候下载结束了，点击关闭或确定，会打开下载附件的文件夹

'------下载完成--------
    result = MsgBox("附件已下载完成，请至目标文件夹查看！", 0 + 64 + 0, "下载成功") '---提示下载完成
    Select Case result
    Case 1
    Shell "explorer.exe " & path, vbNormalFocus '---打开输出文件夹
    End Select
'------下载完成--------