使用 Excel VBA 创建包含具有特定值的行的 Outlook 电子邮件正文

我使用了一个示例来创建代码，使用“按钮”（在我的文件中为红色）从 Excel（使用 Outlook）发送电子邮件。

该代码有效。有一个预选的行范围 [B1:K20]，可以手动修改，这要归功于应用程序.输入框功能。

Sub MAIL()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBodyIn, StrBodyEnd As String

StrBodyIn = "Bonjour," & "<br>" & _
           " " & "<br>" & _
          "Buongiorno," & "<br>"

StrBodyEnd = " " & "<br>" & _
             "Cordialement" & "<br>" & _
             " " & "<br>" & _
             Range("M2") & "<br>"

Set rng = Nothing

On Error Resume Next
Set rng = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0

If rng Is Nothing Then
    MsgBox "ATTENZIONE!!!" & _
           vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
    Exit Sub
End If

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

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

On Error Resume Next
With OutMail
    .To = "[email protected] /cdn-cgi/l/email-protection"
    .CC = ""
    .BCC = ""
    .Subject = "SITUATION"
    .HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(rng) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
    .Display 'or use .Send
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

我想加一个条件。

如果“A”列中写有“X”符号，则应将选定的行范围复制到电子邮件正文。

在我的示例中，应复制第 n° 1、2 和 n° 5 行。

这里的两个任务是分开的，所以我会这样对它们进行编码。这是我的方法。将您的子程序分成两个逻辑过程。

1. 确定身体范围
2. 发送包含范围的电子邮件

确定身体范围

将您的按钮链接到该宏。该宏将接受输入并将其转换为单列范围（Column B）。然后我们将循环遍历选定的范围并查看Column A来确定是否存在x或不。如果x存在，我们将把范围调整回原来的大小，并将其添加到单元格集合中（Final).

循环完成后，宏将执行以下操作之一：

1. 如果范围为空，它将提示您的消息框并结束子（您的电子邮件宏永远不会启动）
2. 如果范围不为空，我们将致电您EMAIL宏并将范围传递给它。

Sub EmailRange()

Dim Initial As Range, Final As Range, nCell As Range

On Error Resume Next
    Set Initial = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0

For Each nCell In Initial.Resize(Initial.Rows.Count, 1)
    If nCell.Offset(, -1) = "X" Then
        If Not Final Is Nothing Then
            Set Final = Union(Final, nCell.Resize(1, Initial.Columns.Count))
        Else
            Set Final = nCell.Resize(1, Initial.Columns.Count)
        End If
    End If
Next nCell

If Not Final Is Nothing Then
    MAIL Final
Else
    MsgBox "ATTENZIONE!!!" & vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
End If

End Sub

发送包含范围的电子邮件

请注意，宏现在有一个输入（在第一行）。如果调用子程序，您不再需要验证任何内容，因为这一切都是在原始子程序中完成的！

Sub MAIL(Final as Range)

Dim OutApp As Object, OutMail As Object
Dim StrBodyIn As String, StrBodyEnd As String

StrBodyIn = "Bonjour," & "<br>" & " " & "<br>" & "Buongiorno," & "<br>"
StrBodyEnd = " " & "<br>" & "Cordialement" & "<br>" & " " & "<br>" & Range("M2") & "<br>"

Application.EnableEvents = False
Application.ScreenUpdating = False

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

    On Error Resume Next
        With OutMail
            .To = "[email protected] /cdn-cgi/l/email-protection"
            .CC = ""
            .BCC = ""
            .Subject = "SITUATION"
            .HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(Final) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
            .Display 'or use .Send
        End With
    On Error GoTo 0

  Set OutMail = Nothing
  Set OutApp = Nothing

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub