Question

我有一个代码：

Sub sendEmail()
  Dim OutlookApp As Object
  Dim OutlookItem As Object
  Dim i As Integer
  Dim Address As String

  Set OutlookApp = CreateObject("Outlook.Application")
  Set OutlookItem = OutlookApp.CreateItem(0)

  With OutlookItem
    For i = 4 To 15
      If Cells(i, 18) <= Cells(i, 6) Then
        Address = Cells(i, 14).Value
        Set OutlookApp = CreateObject("Outlook.application")
        Set OutlookItem = OutlookApp.CreateItem(0)

        .To = Address
        .Subject = "Calibration Due Soon !!!"
        .Body = "Reminder: Calibration of " & Cells(i, 4) & "is due on " & Cells(i, 9)
        .Send

        Set OutlookItem = Nothing
        Set OutlookApp = Nothing

        'Application.Wait (Now + #12:00:08 AM#)
      ElseIf Cells(i, 18) > Cells(i, 15) Then
        Exit Sub
      ElseIf Cells(i, 18) = "" And Cells(i, 15) = "" Then
        Exit Sub
      End If
    Next i
  End With
End Sub

它只发送第一封电子邮件然后它提示我运行时错误说：

该项目已被移动或删除

调试器突出显示“.To = Address”行。当我使用.Display而不是发送它时。有什么想法吗？

Answer 1

在每次循环迭代中重新创建Outlook应用程序对象都没有意义。它相当于杀死Outlook并为您发送的每封邮件重新启动它。我们不要那样做。

首先，在Excel VBA项目中设置对“Microsoft Outlook 15.0对象库”的引用（或者您碰巧安装的任何版本）。

现在，您可以使用New直接创建Outlook对象，它还可以启用自动完成功能以及所有特定于Outlook的常量，例如olMailItem。

现在你的代码可以压缩成这样的东西：

Sub sendEmail()
  Dim OutlookApp As New Outlook.Application
  Dim r As Range

  For Each r In ActiveSheet.Range("4:15").Rows
    If r.Cells(18) <= r.Cells(6) And r.Cells(18) > "" And r.Cells(15) > "" Then
      With OutlookApp.CreateItem(olMailItem)
        .To = r.Cells(14)
        .Subject = "Calibration Due Soon !!!"
        .Body = "Reminder: Calibration of " & r.Cells(4) & " is due on " & r.Cells(9)
        .Send
      End With
    End If
  Next r

  OutlookApp.Quit
  Set OutlookApp = Nothing
End Sub

发送自动电子邮件循环

1 个答案: