请求修改Outlook批量发邮件VBA代码：实现按每7个PDF发票为一批批量发送，最后一批处理剩余文件并匹配对应主题与正文

Sub SendBatchInvoiceEmails()
    Dim path As String
    Dim counter As Integer
    Dim pdfFiles() As String
    Dim fileCount As Integer
    Dim i As Integer, batchStart As Integer, batchEnd As Integer
    Dim batchSize As Integer
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim OutAccount As Outlook.Account
    Dim sourcePath As String
    Dim startInvoice As String, endInvoice As String
    Dim invoiceCount As Integer
    Dim ms As Integer
    
    ' 初始化变量
    ms = 0
    batchSize = 7 ' 每批7个文件，可根据需要调整
    counter = ThisWorkbook.Worksheets("Sheet").Range("I4").Value
    path = ThisWorkbook.Worksheets("Sheet").Range("M2").Value
    
    ' 检查文件夹路径是否为空
    If path = "" Then
        MsgBox "未选择文件夹，请选择包含发票的文件夹。", vbExclamation
        Exit Sub
    End If
    
    ' 收集所有PDF文件到数组（确保按顺序处理）
    fileCount = 0
    fname = Dir(path & "\*.pdf")
    Do While fname <> ""
        fileCount = fileCount + 1
        ReDim Preserve pdfFiles(1 To fileCount)
        pdfFiles(fileCount) = fname
        fname = Dir()
    Loop
    
    ' 检查是否有PDF文件
    If fileCount = 0 Then
        MsgBox "指定文件夹里找不到任何PDF发票文件哦！", vbExclamation
        Exit Sub
    End If
    
    ' 只创建一次Outlook对象，避免重复消耗资源
    Set OutApp = CreateObject("Outlook.Application")
    Set OutAccount = OutApp.Session.Accounts.Item(2) ' 这里用第二个账号，根据你的Outlook账号顺序调整
    
    ' 按批次循环处理
    For batchStart = 1 To fileCount Step batchSize
        ' 计算当前批次的结束位置，最后一批不足7个时自动适配
        batchEnd = batchStart + batchSize - 1
        If batchEnd > fileCount Then batchEnd = fileCount
        
        ' 提取批次首尾的发票名称（去掉.pdf后缀）
        startInvoice = Split(pdfFiles(batchStart), ".")(0)
        endInvoice = Split(pdfFiles(batchEnd), ".")(0)
        invoiceCount = batchEnd - batchStart + 1
        
        ' 创建新邮件
        Set OutMail = OutApp.CreateItem(olMailItem)
        
        With OutMail
            .To = "info@abc.co.uk"
            ' 自动生成邮件主题
            .Subject = startInvoice & " to " & endInvoice
            ' 自动生成邮件正文
            .HTMLBody = "Please find attached the following invoices " & startInvoice & " to " & endInvoice & " (" & invoiceCount & " invoices)"
            .SendUsingAccount = OutAccount
            
            ' 批量添加当前批次的所有附件
            For i = batchStart To batchEnd
                sourcePath = path & "\" & pdfFiles(i)
                .Attachments.Add sourcePath
            Next i
            
            ' 测试时可以把.Send换成.Display，先预览邮件再发送
            '.Display
            .Send
        End With
        
        ms = ms + 1
        ' 每发一封等10秒，避免触发Outlook的发送频率限制
        Application.Wait Now + #12:00:10 AM#
        
        ' 释放当前邮件对象
        Set OutMail = Nothing
    Next batchStart
    
    ' 清理Outlook对象
    Set OutApp = Nothing
    
    MsgBox "处理完成！一共发送了 " & ms & " 封邮件。", vbInformation
End Sub

• 先收集所有文件再分组：把文件夹里的所有PDF发票先存到数组里，这样可以精准按7个一组划分，不会出现漏发或重复发送的情况。
• 动态批次计算：自动处理最后一批不足7个的情况，比如你提到的剩余3个文件会单独成一封邮件。
• 自动生成主题和正文：根据每批的首尾发票名称，自动拼接符合要求的主题和正文，无需手动修改。
• 优化Outlook对象创建：原代码每次循环都创建Outlook对象，现在只创建一次，运行更高效，也减少报错概率。
• 批量添加附件：针对每封邮件，一次性添加该批次的所有PDF文件，实现一封邮件带多个附件的需求。
• 增加异常提示：如果没选文件夹或者找不到PDF文件，会弹出提示，避免程序无意义运行。

1. 确保你的PDF发票文件名是按顺序命名的（比如Invoice 001.pdf、Invoice 002.pdf...Invoice 150.pdf），这样批次的发票范围才会准确。
2. 代码里OutApp.Session.Accounts.Item(2)是用Outlook的第二个发送账号，如果你要用来发送邮件的账号是第一个，把Item(2)改成Item(1)就行。
3. 测试的时候建议把.Send注释掉，换成.Display，先查看邮件的主题、正文和附件是否正确，确认没问题再改回.Send正式发送。

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