Outlook宏功能完善需求：添加附件至草稿邮件并删除本地文件

用户设置系统将所有发票邮件发送到Outlook指定文件夹，现有宏已能将文件夹中的PDF附件保存到本地并生成邮件草稿，需要补充两个功能：

• 将本地保存的所有发票附件添加到邮件草稿
• 添加完成后删除本地的这些文件

以下是修改后的完整宏代码：

Sub ConsolidateClientInvoices()
    Dim ol As Outlook.Application
    Dim ns As Outlook.NameSpace
    Dim fol As Outlook.MAPIFolder
    Dim i As Object
    Dim mi As Outlook.MailItem
    Dim at As Outlook.Attachment
    ' 定义本地保存路径常量，便于后续修改维护
    Const savePath As String = "C:\Users\MYNAME\OneDrive\CLIENT Invoices\"
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    
    ' 初始化Outlook核心对象
    Set ol = New Outlook.Application
    Set ns = ol.GetNamespace("MAPI")
    Set fol = ns.GetDefaultFolder(olFolderInbox)
    Set fol = fol.Folders("_CLIENT INVOICES")
    
    ' 遍历指定邮件文件夹，导出PDF附件到本地
    For Each i In fol.Items
        If i.Class = olMail Then
            Set mi = i
            If mi.Attachments.Count > 0 Then
                For Each at In mi.Attachments
                    ' 兼容大小写后缀，只处理PDF格式附件
                    If LCase(Right(at.FileName, 3)) = "pdf" Then
                        at.SaveAsFile savePath & at.FileName
                    End If
                Next at
            End If
        End If
    Next i
    
    ' 创建邮件草稿并批量添加本地附件
    Dim outlookmessage As Outlook.MailItem
    Set outlookmessage = ol.CreateItem(olMailItem)
    
    With outlookmessage
        .SentOnBehalfOfName = "OUR EMAIL"
        .To = "CLIENT EMAIL"
        .Subject = "Invoices"
        .Body = "Dear Valued Client," & vbNewLine & vbNewLine & _
                "Attached please find the invoices for services provided." & vbNewLine & vbNewLine & _
                "Thank you,"
        ' 调用文件系统对象遍历本地文件夹
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set folder = fso.GetFolder(savePath)
        For Each file In folder.Files
            If LCase(fso.GetExtensionName(file.Name)) = "pdf" Then
                .Attachments.Add file.Path
            End If
        Next file
        .Display
    End With
    
    ' 删除本地文件夹中的PDF文件，添加错误处理避免文件占用报错
    For Each file In folder.Files
        If LCase(fso.GetExtensionName(file.Name)) = "pdf" Then
            On Error Resume Next
            Kill file.Path
            On Error GoTo 0
        End If
    Next file
    
    ' 释放所有对象，避免内存泄漏
    Set file = Nothing
    Set folder = Nothing
    Set fso = Nothing
    Set outlookmessage = Nothing
    Set fol = Nothing
    Set ns = Nothing
    Set ol = Nothing
End Sub

关键修改说明 #

• 统一对象实例：不再重复创建Outlook.Application对象，复用初始化的实例，减少资源消耗
• 路径常量化：将本地保存路径设为常量，后续修改路径只需调整一处
• 批量添加附件：通过FileSystemObject遍历本地文件夹，自动将所有PDF附件添加到邮件草稿
• 安全清理文件：添加错误处理逻辑，避免因文件被占用导致宏执行中断
• 大小写兼容：判断文件后缀时转为小写，避免遗漏大写格式的PDF文件

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