Excel VBA Outlook-动态电子邮件收件人

Posted 2021-04-29

我目前正在尝试创建代码，该代码将根据Excel中的单元格是否满足特定条件（在这种情况下为“是”）向选定的收件人发送电子邮件。我在代码工作方面取得的成功有限，但它只会在看到“是”条件的范围内发送给第一个用户。这是我目前正在使用的代码：

Sub Read_Emails()

' SET Outlook APPLICATION OBJECT.

Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")

' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)

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

With objEmail
    .To = cell.Value
    .CC = ""
    .Subject = "Subject here"
    .BodyFormat = olFormathtml
    .HTMLBody = "Hello," & "<p>" & "Message here."
    .Send
End With
End If
Next cell


Set objEmail = Nothing
Set objOutlook = Nothing

End Sub

答案

我自己可以使用https://www.rondebruin.nl/win/s1/outlook/bmail5.htm对此进行故障排除。

下面的代码针对那些对类似问题感兴趣的人：

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("L").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" And _
       LCase(Cells(cell.Row, "P").Value) = "yes" Then

        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = cell.Value
            .Subject = "Subject here"
            .Body = "Hello " & Cells(cell.Row, "K").Value & "," _
              & vbNewLine & vbNewLine & _
                    "Message here."
            'You can add files also like this
            '.Attachments.Add ("C:	est.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