VBA：通过电子邮件向每个收件人发送不同范围的图像

Question

我正在尝试使用 outlook 自动发送电子邮件。

到目前为止，我的代码能够：

• 向不同的收件人发送不同的附件
• 将 excel 工作表的相同范围（例如：A1:B3）作为 email 正文中的图像发送给所有收件人
• 个性化留言

我想要的是将不同的范围发送给不同的收件人（如附件），例如：

• Email 1：范围A1 B3
• Email 2：范围A4:B7
• Email 3：范围A8:B11
• ETC...

有没有可能让它循环或某事？

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 PictureRange As Range
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
        
        MakeJPG = CopyRangeToJPG("Sheet1", "F31: J37")
        
    If MakeJPG = "" Then
        MsgBox "Something go wrong, we can't create the mail"
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
        Exit Sub
    End If
    
    On Error Resume Next

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
            .Display
                .To = cell.Value
                .Subject = Range("B11") & Range("H13") & " - " & cell.Offset(0, 2)
                .Attachments.Add MakeJPG, 1, 0
                .HTMLBody = "Bonjour " & cell.Offset(0, -1).Value & "," & "<br/>" & "<br/>" & Range("B15") & " " & Range("C15") & " " & Range("D15") & "<p>" & Range("B16") & "<p>" & "<\p>" & "</p><img src=""cid:NamePicture.jpg"" width=550 height=150></html>" & "<p>" & "<\p>" & Range("B17") & .HTMLBody
                
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

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

    With ActiveWorkbook
        On Error Resume Next
        .Worksheets(NameWorksheet).Activate
        Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
        
        If PictureRange Is Nothing Then
            MsgBox "Sorry this is not a correct range"
            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 & "NamePicture.jpg", "JPG"
        End With
        .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
    End With
    
    CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
    Set PictureRange = Nothing
End Function


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

Answer 1

设置初始图像范围，然后在每次发送 email 后对其进行偏移。

Set rngImage = sh.Range("F27:J28")
Set rngImage = rngImage.Offset(rngImage.Rows.Count)

使用常量TEST = True ，此代码应该在不发送电子邮件的情况下运行。 如果正确设置TEST = False 。

Option Explicit

Sub Send_Files()

    Dim OutApp As Object, OutMail As Object
    Dim ws As Worksheet, cell As Range, cellA, rngA As Range
    Dim jpgFilename As String, filename As String, html As String
    Dim rngImage As Range, sImage As String, n As Long
    
    Const TEST = True ' set to False to use Outlook
    Const IMG_NAME = "Image_"
    Const IMG_RANGE = "F27:J28" ' first email
    
    If Not TEST Then
        Set OutApp = CreateObject("Outlook.Application")
    End If

    Set ws = Sheets("Sheet1")
    Set rngImage = ws.Range(IMG_RANGE) ' first image
    
    ' scan column B for valid email addresses
    For Each cell In ws.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    
        'Enter the path/file names in the C:Z column in each row
        Set rngA = cell.Offset(,1).Resize(, 24) ' C:Z attachments
        If Application.WorksheetFunction.CountA(rngA) = 0 Then
            ' no attachments - do nothing
        ElseIf cell.Value Like "?*@?*.?*" Then
        
            sImage = IMG_NAME & rngImage.Row & ".jpg" ' unique image name for each email
            jpgFilename = CopyRangeToJPG(rngImage, sImage)
            
            ' email body
            html = "Bonjour " & cell.Offset(0, -1).Value & "," & "<br/><br/>" _
                    & ws.Range("B15") & " " & ws.Range("C15") & " " & ws.Range("D15") & _
                    "<p>" & ws.Range("B16") & "</p><br/>" & _
                    "<img src=""cid:" & sImage & """ width=550 height=150>" & _
                    "<br/>" & ws.Range("B17")
            If TEST Then
                MsgBox "Image: " & jpgFilename & vbLf & html, vbInformation, "To: " & cell.Value
                'Debug.Print html
            Else
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .Display
                    .To = cell.Value
                    .Subject = Range("B11") & Range("H13") & " - " & cell.Offset(0, 2)
                    .Attachments.Add jpgFilename, 1, 0
                    .HTMLBody = html & .HTMLBody
                    
                    ' add attachments
                    For Each cellA In rngA.SpecialCells(xlCellTypeConstants)
                        filename = Trim(cellA.Value)
                        If filename <> "" Then
                            If Dir(filename) <> "" Then ' check file exists
                                .Attachments.Add filename
                            Else
                                MsgBox "Could not attach : " & filename, vbExclamation, cell.Value
                            End If
                        End If
                    Next
                End With
                Set OutMail = Nothing
            End If
            
            ' next image
            Set rngImage = rngImage.Offset(rngImage.Rows.Count)
            n = n + 1
            
        End If
    Next
    Set OutApp = Nothing
    
    MsgBox n & " emails sent", vbInformation
   
End Sub

Function CopyRangeToJPG(rngImage As Range, filename As String) As String
    
    Dim ws As Worksheet, folder As String
    Set ws = rngImage.Parent ' sheet
    
    ' check range
    If rngImage Is Nothing Then
        MsgBox "Sorry this is not a correct range"
        CopyRangeToJPG = ""
        Exit Function
    End If
    
    ' create image file
    folder = Environ$("temp") & Application.PathSeparator
    rngImage.CopyPicture
    With ws.ChartObjects.Add(rngImage.Left, rngImage.Top, rngImage.Width, rngImage.Height)
        .Activate
        .Chart.Paste
        .Chart.Export folder & filename, "JPG"
    End With
    ws.ChartObjects(ws.ChartObjects.Count).Delete
    
    ' return status
    CopyRangeToJPG = folder & filename
    
End Function