Question

代码成功发送了第一封电子邮件，但我在第二封邮件中遇到错误。

[运行时错误'-2147221238（8004010a）'：项目已被移动或删除]。

我的目标是使用该按钮根据IF语句中的条件自动发送提醒电子邮件。调试引用.To = Recipient行。

Private Sub CommandButton1_Click()

Dim objOutlook As Object
Dim objEmail As Object
Dim Row As Integer
Dim Recipient As String
Dim Requestor As String
Dim CQID As String
Dim lastRow As Long

Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(olMailItem)

lastRow = Cells(Rows.Count, 1).End(xlUp).Row

With objEmail
    For Row = 2 To lastRow
        If Cells(Row, 12).Value = "10" And IsEmpty(Cells(Row, 13).Value) = True Then 'Prepares and sends email after 10 days and no reminder has already been sent. The second constraint is to prevent multiple emails from being sent if the button is pressed multiple times in the day.
            Recipient = Cells(Row, 14).Value
            Requestor = Cells(Row, 15).Value
            CQID = Cells(Row, 1).Value
            .To = Recipient '<---Debug reference
            .CC = Requestor
            .Subject = "Update Requested for " & CQID
            .Body = "Please send us an update on " & CQID
            '.Display
            .Send
            Cells(Row, 13).Value = "1st Reminder Sent" 'Prepares constraint for second reminder
        End If
        If Cells(Row, 12).Value = "15" And Cells(Row, 13).Value = "1st Reminder Sent" Then
            Recipient = Cells(Row, 14).Value
            Requestor = Cells(Row, 15).Value
            .To = Recipient
            .CC = Requestor
            .Subject = "Update Requested for " & CQID
            .Body = "Please send us an update on " & CQID
            '.Display
            .Send
            Cells(Row, 13).Value = "2nd Reminder Sent"
            End If
    Next Row
End With

Set objEmail = Nothing
Set objOutlook = Nothing

End Sub

非常感谢任何直接问题的帮助或一般改进的建议。

Answer 1

无需第二组objEmail来创建新的Outlook项目，只需将其移动到循环中

   Dim Row As Long
    For Row = 2 To lastRow        
        Dim objEmail As Object
        Set objEmail = objOutlook.CreateItem(0)

在引用 Cells(Row

时，在代码中指定工作簿或工作表也非常无能为力

实施例

Option Explicit
Private Sub CommandButton1_Click()
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")

    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets("Sheet1")

    With Sht
        Dim lastRow As Long
            lastRow = .Cells(Rows.Count, 1).End(xlUp).Row

        Dim Row As Long
        For Row = 2 To lastRow
            Dim objEmail As Object
            Set objEmail = objOutlook.CreateItem(0)

            If Sht.Cells(Row, 12).Value = "10" And _
                 IsEmpty(Sht.Cells(Row, 13).Value) = True Then

                Dim Recipient As String
                Dim Requestor As String
                Dim CQID As String

                With objEmail
                     Recipient = Sht.Cells(Row, 14).Value
                     Requestor = Sht.Cells(Row, 15).Value
                     CQID = Sht.Cells(Row, 1).Value
                    .To = Recipient
                    .CC = Requestor
                    .Subject = "Update Requested for "
                    .Body = "Please send us an update on "
                    .Display
    '                .Send
                     Sht.Cells(Row, 13).Value = "1st Reminder Sent"
                End With '<-email

            Else

                If Sht.Cells(Row, 12).Value = "15" And _
                   Sht.Cells(Row, 13).Value = "1st Reminder Sent" Then

                    With objEmail
                         Recipient = Sht.Cells(Row, 14).Value
                         Requestor = Sht.Cells(Row, 15).Value
                        .To = Recipient
                        .CC = Requestor
                        .Subject = "Update Requested for " & CQID
                        .Body = "Please send us an update on " & CQID
                        .Display
    '                    .Send
                         Sht.Cells(Row, 13).Value = "2nd Reminder Sent"
                    End With '<-email
                End If

            End If
        Next Row
    End With '<-sht

    Set objEmail = Nothing
    Set objOutlook = Nothing

End Sub

<强> See fully qualified examples

发送电子邮件时第二次出错

1 个答案: