Outlook VBA中如何用Select Case按发件人邮箱分文件夹存附件

核心修改逻辑 #

原有代码将strFolderpath硬编码在邮件遍历循环外部，所有选中邮件会共用同一个保存路径，无法实现分客户存储。要实现需求需做4处调整：

• 将路径赋值逻辑移到单封邮件处理的循环内部，逐封邮件匹配对应保存路径
• 增加发件人邮箱地址兼容获取逻辑，同时适配企业Exchange内部邮箱、外部SMTP邮箱两种场景，避免地址格式错误导致匹配失效
• 新增Select Case判断块，统一维护邮箱与客户文件夹的映射关系，后续新增、修改规则只需要调整Case内的条目即可
• 增加文件夹不存在自动创建逻辑，避免路径不存在导致附件保存报错

修改后完整可运行代码 #

Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objNamespace As Outlook.Namespace '补全原有缺失的变量声明
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim strSenderEmail As String '新增：存储当前邮件发件人邮箱
Dim fso As Object '新增：用于判断/创建文件夹

' 初始化文件系统对象
Set fso = CreateObject("Scripting.FileSystemObject")

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

' Call the Namespace to see the sender e-mail address.
Set objNamespace = objOL.GetNamespace("MAPI")

' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection

    ' 仅处理邮件类项目，跳过日历、任务等非邮件选中项
    If objMsg.Class = olMail Then
        ' === 获取当前邮件发件人SMTP邮箱地址开始 ===
        If objMsg.SenderEmailType = "EX" Then
            ' 处理企业Exchange内部邮箱，获取真实SMTP地址
            strSenderEmail = objMsg.Sender.GetExchangeUser.PrimarySmtpAddress
        Else
            ' 处理外部SMTP邮箱
            strSenderEmail = objMsg.SenderEmailAddress
        End If
        ' 统一转小写，避免大小写差异导致匹配失败
        strSenderEmail = LCase(strSenderEmail)
        ' === 获取发件人邮箱结束 ===

        ' === Select Case 匹配发件人对应文件夹路径开始 ===
        Select Case strSenderEmail
            ' 按实际客户邮箱和路径修改以下条目即可，多个邮箱对应同一客户用逗号分隔
            Case "customerA@companyA.com"
                strFolderpath = "C:\Folder\客户A专属文件夹\"
            Case "customerB@companyB.com", "vip@companyB.com"
                strFolderpath = "C:\Folder\客户B专属文件夹\"
            Case "customerC@companyC.com"
                strFolderpath = "C:\Folder\客户C专属文件夹\"
            ' 匹配不到任何规则时使用默认路径
            Case Else
                strFolderpath = "C:\Folder\Test\"
        End Select
        ' === 路径匹配结束 ===

        ' 如果目标文件夹不存在则自动创建
        If Not fso.FolderExists(strFolderpath) Then
            fso.CreateFolder strFolderpath
        End If

        ' Get the Attachments collection of the item.
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
        strDeletedFiles = ""

        If lngCount > 0 Then

            ' 倒序遍历附件集合，避免删除操作导致的集合索引错乱
            For i = lngCount To 1 Step -1

                ' Save attachment before deleting from item.
                ' Get the file name.
                strFile = objAttachments.Item(i).FileName

                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & strFile

                ' Save the attachment as a file.
                objAttachments.Item(i).SaveAsFile strFile

                ' Delete the attachment.
                objAttachments.Item(i).Delete

                'write the save as path to a string to add to the message
                'check for html and use html tags in link
                If objMsg.BodyFormat <> olFormatHTML Then
                    strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
                Else
                    strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                    strFile & "'>" & strFile & "</a>"
                End If

                '调试用，正式使用可注释
                'MsgBox strDeletedFiles

            Next i

            ' 将保存路径写入邮件正文并保存邮件
            If objMsg.BodyFormat <> olFormatHTML Then
                objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
            Else
                objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
            End If
            objMsg.Save
        End If
    End If
Next

ExitSub:
' 释放所有对象
Set fso = Nothing
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set objNamespace = Nothing
End Sub

后续维护说明 #

• 新增客户规则时，只需要在Select Case块中新增Case "客户邮箱地址"行，下一行写对应客户的文件夹路径即可
• 若同一个客户有多个发件邮箱，直接在Case后用逗号分隔多个邮箱地址即可，不需要重复写路径赋值
• 代码默认会自动创建不存在的客户文件夹，不需要手动提前新建目录

内容的提问来源于stack exchange，提问作者shab3y