在邮件中复制多个范围

Posted 2023-04-19

【中文标题】在邮件中复制多个范围

【英文标题】：Copy multiple range in mail

【发布时间】：2018-03-15 04:16:27

【问题描述】：

我想向第 4 行发送一封电子邮件，使其保持不变，第 5 行保持动态。 第一封邮件将包含第 4 行和第 5 行以下的数据 那么第二封邮件将包含第 4 行和第 6 行以下的数据，依此类推。

Sub Send_Range_Or_Whole_Worksheet_with_MailEnvelope()
'Working in Excel 2002-2016
    Dim AWorksheet As Worksheet
    Dim Sendrng As Range
    Dim rng As Range

    On Error GoTo StopMacro

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

    'Fill in the Worksheet/range you want to mail
    'Note: if you use one cell it will send the whole worksheet
    Set Sendrng = Application.Union(Range("A4"), Range("A6")).EntireRow

    'Remember the activesheet
    Set AWorksheet = ActiveSheet

    With Sendrng

        ' Select the worksheet with the range you want to send


        'Remember the ActiveCell on that worksheet

        'Select the range you want to mail
        .Select

        ' Create the mail and send it
        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

            ' Set the optional introduction field thats adds
            ' some header text to the email body.
            .Introduction = "This is test mail 2."

            With .Item
                .To = "xxxx"
                .CC = ""
                .BCC = ""
                .Subject = "My subject"
                .Body = Sendrng
                .Send
            End With

        End With

        'select the original ActiveCell
        rng.Select
    End With

    'Activate the sheet that was active before you run the macro
    AWorksheet.Select

StopMacro:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    ActiveWorkbook.EnvelopeVisible = False

End Sub

我尝试使用此代码，但它没有发送所需的范围。 我不想将数据复制并粘贴到另一个工作表然后发送邮件，因为它会减慢宏，因为我需要向 60 多人发送邮件。

有什么方法可以在邮件中发送选定的范围？ 我还附上了一张示例图片供您参考。

【问题讨论】：

是否可以发送包含其他人标记的隐藏行？还是他们只能看到自己的标记？

【参考方案1】：

首先尝试以下方法：

Sub Send_Range_Or_Whole_Worksheet_with_MailEnvelope()

    On Error GoTo StopMacro

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

    Dim AWorksheet As Worksheet
    Dim Sendrng As Range
    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim loopRange As Range

    Set wb = ThisWorkbook
    Set wsSource = wb.Worksheets("Sheet1")

    wsSource.Cells.EntireRow.Hidden = False

    Set loopRange = wsSource.Range("A4").CurrentRegion 'Could also use last row method

    Dim currentName As Long

    For currentName = 2 To loopRange.Rows.Count

        loopRange.EntireRow.Hidden = True

        Union(loopRange.Rows(1), loopRange.Rows(currentName)).EntireRow.Hidden = False

        Set Sendrng = loopRange.SpecialCells(xlCellTypeVisible)

        Set AWorksheet = ActiveSheet

        With Sendrng

            .Parent.Select

            Set rng = ActiveCell

            .Select

            ActiveWorkbook.EnvelopeVisible = True

            With .Parent.MailEnvelope

                .Introduction = "This is test mail 2."

                With .Item
                    .to = "xxx"
                    .CC = ""
                    .BCC = ""
                    .Subject = "My subject"
                    .Send                        '.Display
                End With

            End With

        End With

    Next currentName

StopMacro:

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With

    ActiveWorkbook.EnvelopeVisible = False

    wsSource.Cells.EntireRow.Hidden = False

End Sub

补充说明：

如果您想使用最后一行方法而不是CurrentRegion 来设置loopRange，那么您可以替换

  Set loopRange = wsSource.Range("A4").CurrentRegion 'Could also use last row method

有

Dim lastRow As Long

With wsSource
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Set loopRange = wsSource.Range("A4:C" & lastRow)

第 2 版整理：

这是我更喜欢的版本 2（基于 Paul-Jan 的回答）：

Public Sub Send_Range()

    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim loopRange As Range

    On Error GoTo StopMacro

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

    On Error GoTo StopMacro

    Set wb = ThisWorkbook
    Set wsSource = wb.Worksheets("Sheet1")

    wsSource.Cells.EntireRow.Hidden = False

    Dim StrBody As String

    StrBody = "This is test mail 2.," & "<br>" & "<br>" & _
              "Please find you marks below." & "<br><br>"


    Dim lastRow As Long

    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    Set loopRange = wsSource.Range("A4:C" & lastRow)

    Dim currentName As Long

    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")

    For currentName = 2 To loopRange.Rows.Count

        Set OutMail = OutApp.CreateItem(0)

        loopRange.EntireRow.Hidden = True

        Union(loopRange.Rows(1), loopRange.Rows(currentName)).EntireRow.Hidden = False

        Set Sendrng = loopRange.SpecialCells(xlCellTypeVisible)

        With OutMail
            .To = "xxx"
            .CC = ""
            .BCC = ""
            .Subject = ""
            .htmlBody = StrBody & RangetoHTML(Sendrng)
            .Send                                'or use .Display
        End With


    Next currentName


StopMacro:

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

     wsSource.Cells.EntireRow.Hidden = False

End Sub


Private Function RangetoHTML(ByVal rng As Range)
' By Ron de Bruin.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function