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

Question

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

该代码有效。由于 Application.InputBox 功能，可以手动修改行 [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@gmail.com"
    .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”符号，则应将选定的行范围复制到电子邮件的正文中。



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

Answer 1

这里的两个任务是分开的，所以我会这样编码。这将是我的方法。将您的 sub 分成两个逻辑过程。

确定车身范围

发送范围为

的电子邮件


确定 body 范围

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

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

如果范围为空，它将提示您的消息框并结束子(您的电子邮件宏永远不会启动)

如果范围不为空，我们将调用您的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，您不再需要验证任何内容，因为这一切都是在原始 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@gmail.com"
            .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