如何通过VBA创建批量Outlook邮件，按单封最多10个附件规则添加文件夹文件

• 你的代码每次生成新邮件时，都会从头遍历文件夹内的所有文件，没有跳过之前已经添加到其他邮件的附件
• 阈值变量Z的更新位置错误，放在了内层遍历文件的循环中，导致计数逻辑完全混乱，无法正确拆分每批附件的范围

Sub attach()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sFolder As String
    Dim fs As Object, f As Object, fls As Object
    Dim fileArr() As String
    Dim i As Long, fileCount As Long
    Const BATCH_SIZE As Long = 10 ' 单封邮件最大附件数，可自行修改
    
    ' 选择目标文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        If .Show <> -1 Then Exit Sub ' 用户取消选择则直接退出
        sFolder = .SelectedItems(1)
    End With
    
    ' 读取文件夹内所有文件到数组，方便按索引取数
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(sFolder)
    Set fls = f.Files
    fileCount = fls.Count
    If fileCount = 0 Then Exit Sub ' 文件夹为空直接退出
    
    ReDim fileArr(1 To fileCount)
    i = 1
    For Each x In fls
        fileArr(i) = x.Name
        i = i + 1
    Next
    
    ' 初始化Outlook应用，只需创建一次
    Set OutApp = CreateObject("Outlook.Application")
    
    ' 按批次生成邮件
    For d = 1 To fileCount Step BATCH_SIZE
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = "abc@gmail.com"
            .CC = ""
            .Subject = "file"
            ' 添加当前批次的附件，最多BATCH_SIZE个
            For i = d To WorksheetFunction.Min(d + BATCH_SIZE - 1, fileCount)
                .Attachments.Add sFolder & "\" & fileArr(i)
            Next
            .Display
        End With
        Set OutMail = Nothing
    Next
    
    ' 释放对象
    Set OutApp = Nothing
    Set fs = Nothing
End Sub

• 先把文件夹内的所有文件名存入数组，避免每次生成邮件都从头遍历所有文件，可直接按索引定位当前批次需要添加的附件
• 用常量BATCH_SIZE控制单封邮件的最大附件数，后续需要调整数量时直接修改这个常量即可
• 外层循环按批次步长跳转，直接取对应索引范围的文件作为当前邮件的附件，超出总文件数时自动截止
• 优化了Outlook对象的创建逻辑，不需要每次生成邮件都重复创建Outlook应用实例，运行效率更高
• 增加了用户取消选择文件夹、文件夹为空的异常场景处理，避免代码报错

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