0

我有一个电子邮件地址列表，但我只需要向相应单元格中“过期”的个人发送电子邮件。单击按钮时，它会打开多个 Outlook 窗口。

这是我到目前为止所拥有的：

Private Sub CommandButton1_Click()
Dim c As Range
For Each c In Range("F5:F42")
    If c.Value2 = "Expired" Then Call Mail_small_Text_Outlook(c.Offset(0, -3).Value2)
Next c
End Sub
Sub Mail_small_Text_Outlook(emailAddress As String)

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
Set ws = Sheets("Sheet1")
 Set Rng = ws.Range(ws.Range("A1"), ws.Range("A" & Rows.Count).End(xlUp))
  
    For Each cell In Rng
           
    If cell.Value2 = "Expired" Then
      SendTo = SendTo & cell.Value & ";"
    End If
   Next
    
    strbody = "Hello," & vbNewLine & vbNewLine & _
              "You are receiving this email because your Wastewater Pathogens (Annual) is now expired or will expire within the next 30 days. Please sign up for the next available class in LMS. If you are unable to sign up in LMS, please contact Christa Scott." & vbNewLine & _
              "Thank you and have a nice day."

    On Error Resume Next
    With OutMail
        .To = SendTo
        .CC = ""
        .BCC = ""
        .Subject = "Expired Hazmat Right-to-Know Training - " & Date
        .Body = strbody

        .Display 'or .Send to automatically send email.
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub
4

1 回答 1

1

要从命令按钮运行代码调用一次，并检查 F 列中的“过期”，请使用 cell.Offset(,5).Value2。

Option Explicit

Private Sub CommandButton1_Click()
    Call Mail_small_Text_Outlook
End Sub

Sub Mail_small_Text_Outlook()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strSendTo As String
Dim strBody As String

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

    Set ws = Sheets("Sheet1")
    Set rng = ws.Range(ws.Range("A1"), ws.Range("A" & Rows.Count).End(xlUp))

    For Each cell In rng
        If cell.Offset(, 5).Value2 = "Expired" Then
            strSendTo = strSendTo & cell.Value & ";"
        End If
    Next

    strBody = "Hello," & vbNewLine & vbNewLine & _
              "You are receiving this email because your Wastewater Pathogens (Annual) is now expired or will expire within the next 30 days. Please sign up for the next available class in LMS. If you are unable to sign up in LMS, please contact Christa Scott." & vbNewLine & _
              "Thank you and have a nice day."

    On Error Resume Next
    With OutMail
        .To = strSendTo
        .CC = ""
        .BCC = ""
        .Subject = "Expired Hazmat Right-to-Know Training - " & Date
        .Body = strBody

        .Display    'or .Send to automatically send email.
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub
于 2021-04-09T15:29:22.283 回答