Create Outlook Email Body with rows having a particular value using Excel VBA

问题

I've used an example to create code to send emails from Excel (with Outlook), using a "Button" (red in my file).

The code works. There is a pre-selected range of rows [B1:K20], that can be manually modified thanks to the Application.InputBox function.

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

I want to add a condition.

The selected range of rows should be copied to the body of the email if the "X" symbol is written in the column "A".

In my example, rows n° 1, 2 and n° 5 should be copied.

回答1:

The two tasks here are separate so I would code them as such. Here would be my approach. Separate your sub into two logical procedures.

Determine the body range
Send the email with the range

Determine the body range

Link your button to this macro. The macro will take an input and convert it into a single column range (Column B). We will then loop through the selected range and look at Column A to determine if there is an x or not. If an x is present, we will resize the range back to it's original size and add it to a collection of cells (Final).

Once the loop is complete, the macro will then do one of the following:

If the range is empty, it will prompt your message box and end the sub (your email macro is never initiated)
If the range is not empty, we will call your EMAIL macro and pass the range along to it.

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

Send the email with the range

Notice that the macro now has an input (On first line). If the sub is called, you no longer need to validate anything since this was all done in the original 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

来源：https://stackoverflow.com/questions/54448805/create-outlook-email-body-with-rows-having-a-particular-value-using-excel-vba

标签

excel

vba

outlook

outlook-vba