Outlook VBA宏开发需求：下载指定最新邮件附件并合并Excel工作表

一、核心需求 #

• 宏1：在Outlook中筛选周一至周五收到的三类最新邮件（主题前缀为ABC E-mail subject、DEF E-mail subject、XYZ E-mail subject，仅日期后缀变化），保存其中的.xlsm/.xlsx附件；XYZ类附件需解锁密码后保存，自动忽略同类旧邮件
• 宏2：读取已保存的三类附件（自动处理加密文件解锁），将每个文件中指定的2个及以上工作表复制到Excel模板中

二、当前问题：共享文件夹对象未找到错误 #

原代码中Set fol = ns.Folders(1).Folders("Dell")报错，原因是共享邮箱/群组无法通过索引Folders(1)直接访问，必须通过收件人对象定位共享邮箱，再指定目标文件夹。

三、修正方案与完整代码 #

3.1 宏1：Outlook目标附件保存（含筛选、加密文件处理） #

Option Explicit

Sub SaveTargetOutlookAttachments()
    ' 需提前引用：Microsoft Outlook 16.0 Object Library、Microsoft Scripting Runtime
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim sharedRecipient As Outlook.Recipient
    Dim targetFolder As Outlook.Folder
    Dim mailItem As Outlook.MailItem
    Dim attachment As Outlook.Attachment
    Dim fso As Scripting.FileSystemObject
    Dim savePath As String
    Dim baseSubjects As Variant
    Dim latestMails As Dictionary ' 存储每个主题前缀的最新邮件
    Dim currentSubjectPrefix As String
    Dim receivedWeekday As Integer
    Dim unlockPassword As String
    
    ' 初始化配置参数
    baseSubjects = Array("ABC E-mail subject", "DEF E-mail subject", "XYZ E-mail subject")
    Set latestMails = New Dictionary
    Set fso = New Scripting.FileSystemObject
    savePath = "C:\Outlook Attachments\" ' 自定义附件保存路径
    If Not fso.FolderExists(savePath) Then fso.CreateFolder savePath
    
    ' 连接Outlook并定位共享文件夹
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    ' 替换为实际共享邮箱的地址/名称
    Set sharedRecipient = olNS.CreateRecipient("shared_mailbox@yourdomain.com")
    sharedRecipient.Resolve
    If sharedRecipient.Resolved Then
        ' 若"Dell"是共享邮箱收件箱下的子文件夹，直接定位；否则调整路径层级
        Set targetFolder = olNS.GetSharedDefaultFolder(sharedRecipient, olFolderInbox).Folders("Dell")
    Else
        MsgBox "无法找到指定共享邮箱，请确认收件人信息", vbCritical
        Exit Sub
    End If
    
    ' 遍历邮件，筛选周一至周五的目标邮件，记录每个前缀的最新邮件
    For Each mailItem In targetFolder.Items
        If mailItem.Class = olMail Then
            receivedWeekday = Weekday(mailItem.ReceivedTime)
            ' 仅处理周一至周五（Weekday返回值：2=周一，6=周五）
            If receivedWeekday >= 2 And receivedWeekday <= 6 Then
                ' 匹配主题前缀
                For Each currentSubjectPrefix In baseSubjects
                    If InStr(1, mailItem.Subject, currentSubjectPrefix, vbTextCompare) = 1 Then
                        ' 更新最新邮件：字典无此前缀，或当前邮件时间更新
                        If Not latestMails.Exists(currentSubjectPrefix) Or _
                           mailItem.ReceivedTime > latestMails(currentSubjectPrefix).ReceivedTime Then
                            Set latestMails(currentSubjectPrefix) = mailItem
                        End If
                        Exit For ' 匹配到一个前缀即跳出循环
                    End If
                Next currentSubjectPrefix
            End If
        End If
    Next mailItem
    
    ' 处理最新邮件的附件
    For Each currentSubjectPrefix In latestMails.Keys
        Set mailItem = latestMails(currentSubjectPrefix)
        If mailItem.Attachments.Count > 0 Then
            For Each attachment In mailItem.Attachments
                ' 仅保存xlsm/xlsx格式文件
                If LCase(Right(attachment.FileName, 5)) = ".xlsm" Or _
                   LCase(Right(attachment.FileName, 5)) = ".xlsx" Then
                    Dim tempSavePath As String
                    tempSavePath = savePath & attachment.FileName
                    
                    ' 保存原始附件
                    attachment.SaveAsFile tempSavePath
                    
                    ' XYZ主题附件需解锁后重新保存
                    If currentSubjectPrefix = "XYZ E-mail subject" Then
                        unlockPassword = InputBox("请输入XYZ附件的解锁密码：", "密码输入")
                        If unlockPassword <> "" Then
                            Dim excelApp As Object
                            Dim wb As Object
                            Set excelApp = CreateObject("Excel.Application")
                            excelApp.Visible = False
                            ' 打开加密文件并解除密码保存
                            Set wb = excelApp.Workbooks.Open(tempSavePath, Password:=unlockPassword)
                            wb.SaveAs tempSavePath, Password:=""
                            wb.Close SaveChanges:=True
                            excelApp.Quit
                            Set wb = Nothing
                            Set excelApp = Nothing
                        End If
                    End If
                End If
            Next attachment
        End If
    Next currentSubjectPrefix
    
    MsgBox "附件保存完成！", vbInformation
    ' 释放对象
    Set targetFolder = Nothing
    Set sharedRecipient = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Set fso = Nothing
    Set latestMails = Nothing
End Sub

3.2 宏2：读取附件并复制工作表到Excel模板 #

Option Explicit

Sub CopySheetsToTemplate()
    Dim fso As Scripting.FileSystemObject
    Dim sourceFolder As Scripting.Folder
    Dim sourceFile As Scripting.File
    Dim excelApp As Excel.Application
    Dim sourceWB As Excel.Workbook
    Dim templateWB As Excel.Workbook
    Dim targetSheets As Variant
    Dim sheetName As Variant
    Dim unlockPassword As String
    Dim templatePath As String
    Dim savePath As String
    
    ' 配置参数
    targetSheets = Array("数据报表", "汇总表", "明细") ' 替换为实际需要复制的工作表名称
    templatePath = "C:\Templates\ReportTemplate.xlsx" ' 替换为你的Excel模板路径
    savePath = "C:\Final Reports\" ' 最终报表保存路径
    Set fso = New Scripting.FileSystemObject
    
    ' 检查模板文件是否存在
    If Not fso.FileExists(templatePath) Then
        MsgBox "模板文件不存在，请确认路径！", vbCritical
        Exit Sub
    End If
    If Not fso.FolderExists(savePath) Then fso.CreateFolder savePath
    
    ' 初始化Excel应用
    Set excelApp = New Excel.Application
    excelApp.Visible = False
    
    ' 打开模板文件
    Set templateWB = excelApp.Workbooks.Open(templatePath)
    
    ' 遍历附件文件夹中的文件
    Set sourceFolder = fso.GetFolder("C:\Outlook Attachments\")
    For Each sourceFile In sourceFolder.Files
        ' 仅处理xlsm/xlsx格式文件
        If LCase(Right(sourceFile.Name, 5)) = ".xlsm" Or _
           LCase(Right(sourceFile.Name, 5)) = ".xlsx" Then
            ' 尝试打开文件，若加密则提示输入密码
            On Error Resume Next
            Set sourceWB = excelApp.Workbooks.Open(sourceFile.Path)
            If Err.Number <> 0 Then
                Err.Clear
                unlockPassword = InputBox("文件" & sourceFile.Name & "已加密，请输入解锁密码：", "密码输入")
                If unlockPassword <> "" Then
                    Set sourceWB = excelApp.Workbooks.Open(sourceFile.Path, Password:=unlockPassword)
                Else
                    GoTo NextFile ' 未输入密码则跳过当前文件
                End If
            End If
            On Error GoTo 0
            
            ' 复制指定工作表到模板末尾
            For Each sheetName In targetSheets
                On Error Resume Next
                sourceWB.Sheets(sheetName).Copy After:=templateWB.Sheets(templateWB.Sheets.Count)
                If Err.Number <> 0 Then
                    MsgBox "文件" & sourceFile.Name & "中不存在工作表[" & sheetName & "]", vbExclamation
                    Err.Clear
                End If
                On Error GoTo 0
            Next sheetName
            
            sourceWB.Close SaveChanges:=False
        End If
NextFile:
    Next sourceFile
    
    ' 保存最终合并后的模板
    templateWB.SaveAs savePath & "最终报表_" & Format(Now(), "yyyy-mm-dd") & ".xlsx"
    templateWB.Close SaveChanges:=False
    excelApp.Quit
    
    MsgBox "工作表复制完成！", vbInformation
    ' 释放对象
    Set templateWB = Nothing
    Set excelApp = Nothing
    Set sourceWB = Nothing
    Set sourceFile = Nothing
    Set sourceFolder = Nothing
    Set fso = Nothing
End Sub

四、关键注意事项 #

• 共享邮箱访问：需替换代码中的shared_mailbox@yourdomain.com为实际共享邮箱的地址或显示名称；若目标文件夹不在收件箱下，需调整文件夹层级路径
• 密码安全：当前通过输入框获取解锁密码，若需自动化可改为固定密码（不建议，存在安全风险）
• 主题匹配逻辑：代码假设主题前缀完全匹配，若主题格式有变化，需调整InStr的匹配规则
• 工作表复制：确保模板文件存在，且指定的工作表名称与源文件中的表名完全一致

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