Question

我想将Excel中的表格（所有格式完整）复制到电子邮件中，然后将单独的电子邮件发送给Excel中列表中的人员。 Ron de Bruin在他的网站上有两组代码。

一个是第一部分，另一个是第二部分。我该如何结合这些？

http://www.rondebruin.nl/win/s1/outlook/bmail2.htm

Sub Test1()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "C").Value) = "yes" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Reminder"
                .Body = "Dear " & Cells(cell.Row, "A").Value _
                      & vbNewLine & vbNewLine & _
                        "Please contact us to discuss bringing " & _
                        "your account up to date"
                'You can add files also like this
                '.Attachments.Add ("C:\test.txt")
                .Send  'Or use Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

http://www.rondebruin.nl/win/s1/outlook/bmail5.htm

{{1}}

Answer 1

只需更换以下内容

即可

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
    .To = "ron@debruin.nl"
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = RangetoHTML(rng)
    .Send   'or use .Display
End With
On Error GoTo 0

有了这个

Set OutApp = CreateObject("Outlook.Application")

For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" And _
       LCase(Cells(cell.Row, "C").Value) = "yes" Then

        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = cell.Value
            .Subject = "Reminder"
            .Body = "Dear " & Cells(cell.Row, "A").Value _
                  & vbNewLine & vbNewLine & _
                    "Please contact us to discuss bringing " & _
                    "your account up to date"
            'You can add files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send  'Or use Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    End If
Next cell

然后改变这个

        .Body = "Dear " & Cells(cell.Row, "A").Value _
              & vbNewLine & vbNewLine & _
                "Please contact us to discuss bringing " & _
                "your account up to date"

有了这个

.HTMLBody = RangetoHTML(rng)

将表从Excel复制到Outlook并发送到Excel工作表中的多个人

1 个答案: