如何修改VBA代码实现给不同收件人发送不同Excel区域图片

原功能与修改需求 #

原代码实现功能 #

• 为不同收件人发送对应行的不同附件
• 所有邮件正文中插入相同的Excel区域图片
• 发送包含收件人名称的个性化消息

修改需求 #

• 为每个收件人发送专属的Excel区域图片，区域尺寸统一（如2行4列），按顺序依次向下排列
• 示例：第1封邮件对应区域F27:J28，第2封对应F29:J30，第3封对应F31:J32，以此类推

修改后的完整代码 #

Sub Send_Files()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim MakeJPG As String
    Dim mailIndex As Integer ' 跟踪当前是第几个收件人邮件
    Dim startRow As Integer ' 图片区域起始行
    Dim rangeAddress As String ' 动态生成的区域地址

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    mailIndex = 1 ' 初始化邮件序号
    startRow = 27 ' 第一个邮件对应的图片区域起始行

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        ' 跳过表头（如果B1是表头的话）
        If cell.Row = 1 Then GoTo NextCell
        
        ' 动态生成当前邮件对应的Excel区域地址：每次向下偏移2行
        rangeAddress = "F" & startRow & ":J" & startRow + 1
        MakeJPG = CopyRangeToJPG("Sheet1", rangeAddress, mailIndex) ' 传入序号生成唯一文件名
        
        If MakeJPG = "" Then
            MsgBox "生成图片失败，无法创建邮件"
            With Application
                .EnableEvents = True
                .ScreenUpdating = True
            End With
            Exit Sub
        End If
    
        On Error Resume Next

        If cell.Value Like "?*@?*.?*" And _
          Application.WorksheetFunction.CountA(sh.Cells(cell.Row, 3).Resize(1, 24)) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .Display
                .To = cell.Value
                .Subject = sh.Range("B11") & sh.Range("H13") & " - " & cell.Offset(0, 2).Value
                .Attachments.Add MakeJPG, 1, 0 ' 将图片作为嵌入式附件
                ' 个性化邮件正文 + 嵌入式图片
                .HTMLBody = "Bonjour " & cell.Offset(0, -1).Value & "," & "<br/><br/>" & _
                            sh.Range("B15") & " " & sh.Range("C15") & " " & sh.Range("D15") & "<p>" & _
                            sh.Range("B16") & "</p>" & _
                            "<img src=""cid:NamePicture_" & mailIndex & ".jpg"" width=550 height=150>" & "<p>" & _
                            sh.Range("B17") & "</p>" & .HTMLBody
                
                ' 添加对应行的附件
                For Each FileCell In sh.Cells(cell.Row, 3).Resize(1, 24).SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell.Value) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

            End With

            Set OutMail = Nothing
        End If
        
        ' 更新序号和起始行，准备下一个邮件
        mailIndex = mailIndex + 1
        startRow = startRow + 2
NextCell:
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    ' 清理临时图片文件
    Kill Environ$("temp") & Application.PathSeparator & "NamePicture_*.jpg"
End Sub


Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String, imgIndex As Integer) As String
    Dim PictureRange As Range
    Dim imgFileName As String

    imgFileName = "NamePicture_" & imgIndex & ".jpg" ' 生成唯一文件名，避免覆盖

    With ActiveWorkbook
        On Error Resume Next
        .Worksheets(NameWorksheet).Activate
        Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
        
        If PictureRange Is Nothing Then
            MsgBox "指定的区域无效：" & RangeAddress
            On Error GoTo 0
            Exit Function
        End If
        
        PictureRange.CopyPicture
        With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
            .Activate
            .Chart.Paste
            .Chart.Export Environ$("temp") & Application.PathSeparator & imgFileName, "JPG"
        End With
        .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
    End With
    
    CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & imgFileName
    Set PictureRange = Nothing
End Function


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

关键修改点说明 #

• 动态区域计算：新增mailIndex和startRow变量，根据当前邮件序号计算对应的Excel区域，每次向下偏移2行（可根据实际区域行数调整startRow = startRow + 2中的数值）
• 唯一图片文件名：修改CopyRangeToJPG函数，传入序号生成带编号的图片文件，避免后续邮件的图片覆盖之前的文件
• 嵌入式图片引用：HTML正文中的cid对应带编号的图片文件名，确保每个邮件显示正确的专属图片
• 清理临时文件：在代码末尾添加Kill命令，批量删除临时生成的图片文件，避免垃圾文件堆积
• 明确工作表引用：所有单元格引用添加sh.前缀，避免因激活其他工作表导致的错误

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