VBA应用程序定义的错误outlook连接

Question

我有以下代码并一直出现错误“应用程序定义或对象定义错误”并且不明白为什么。 Microsoft Office 16.0 对象库工具已激活，我确信该错误与 Set outlookMail = outlookApp.CreateItem(0) 行有关。可以肯定的是，我在与 outlook 的联系中遗漏了一些东西。

Sub send_emails()

Dim outlookApp As Object
Dim outlookMail As Object
Dim cell As Range
Dim lastRow As Long

' Create Outlook object
Set outlookApp = CreateObject("Outlook.Application")

' Determine the last row in the worksheet
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

' Loop through each cell in column D
For Each cell In Range("D2:D" & lastRow)
  
  ' Check if the date in the cell is 15 days from today
  If cell.Value = Date + 15 Then
    
    ' Retrieve the corresponding email address, name, and surname
    Email = cell.Offset(0, 2).Value
    Name = cell.Offset(0, 1).Value
    surname = cell.Offset(0, -1).Value
    
    ' Create a new email
    Set outlookMail = outlookApp.CreateItem(0)
    
    ' Set the recipient, subject, and body of the email
    outlookMail.To = Email
    outlookMail.Subject = "Reminder"
    outlookMail.Body = "Dear " & Name & " " & surname & ", this is a reminder that your event is coming up in 15 days. Please make sure to prepare accordingly."
    
    ' Set the sender and send the email
    outlookMail.SendUsingAccount = outlookApp.Session.Accounts.Item("YOUR EMAIL ADDRESS")
    outlookMail.Send
    
    ' If the email was sent successfully, color the cell in column E green
    cell.Offset(0, 1).Interior.Color = vbGreen
  End If
Next cell

' Clean up
Set outlookMail = Nothing
Set outlookApp = Nothing

End Sub

Answer 1

Microsoft Office 16.0 对象库工具已激活

我想您已经在 Excel VBA 环境中添加了对 Outlook 对象模型的引用（COM 引用）。在代码中我看到使用了后期绑定技术：

Dim outlookApp As Object
Dim outlookMail As Object
' Create Outlook object
Set outlookApp = CreateObject("Outlook.Application")

但同时您在代码中添加了一个 COM 对象引用以使用早期绑定。因此，我建议使用

New

运算符并在代码中声明 all Outlook 对象而不是特定类型：

Dim outlookApp As Outlook.Application
Dim outlookMail As Outlook.MailItem

Set outlookApp = New Outlook.Application()

您可以在Using early binding and late binding in Automation文章中阅读有关早期和后期绑定技术的更多信息。

Answer 2

从 Excel 发送电子邮件

Option Explicit

Private Enum eCols
    ecSurName = 1 ' C
    ecDate = 2 ' D
    ecName = 3 ' E
    ecEmail = 4 ' F
End Enum

Sub SendEmails()
    
    Const MY_EMAIL As String = "YOUR EMAIL ADDRESS"
    
    On Error GoTo ClearError
    
    ' Reference the worksheet.
    
    If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
    If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    ' Reference the range.
    
    Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If LastRow < 2 Then Exit Sub ' no data
    Dim rg As Range: Set rg = ws.Range("C2", ws.Cells(LastRow, "F"))
    
    ' Write the values from the range to an array.
    
    Dim Data(): Data = rg.Value
    
    ' Write the matching rows to a collection.
    
    Dim coll As Collection: Set coll = New Collection
    
    Dim r As Long, rDate As Variant
    
    For r = 1 To UBound(Data, 1)
        rDate = Data(r, eCols.ecDate)
        If IsDate(rDate) Then
            If rDate = Date + 15 Then coll.Add r
        End If
    Next r
    
    If coll.Count = 0 Then Exit Sub ' no matches
    
    ' Send the emails.
    
    Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
    
    Dim crg As Range, rItem, ErrNum As Long, emCount As Long
    Dim olMail As Object, mEmail As String, mName As String, mSurName As String
    
    For Each rItem In coll
        
        mEmail = Data(rItem, eCols.ecEmail)
        mName = Data(rItem, eCols.ecName)
        mSurName = Data(rItem, eCols.ecSurName)
        
        Set olMail = olApp.CreateItem(0)
        
        With olMail
            .To = mEmail
            .Subject = "Reminder"
            .Body = "Dear " & mName & " " & mSurName _
                & ", this is a reminder that your event is coming up " _
                & "in 15 days. Please make sure to prepare accordingly."
            .SendUsingAccount = olApp.Session.Accounts.Item(MY_EMAIL)
            On Error Resume Next ' suppress send error e.g. if invalid email
                olMail.Send
                ErrNum = Err.Number
            On Error GoTo ClearError
        End With
        
        ' Count and combine cells to be highlighted.
        If ErrNum = 0 Then
            emCount = emCount + 1
            If crg Is Nothing Then
                Set crg = rg.Cells(rItem, eCols.ecName)
            Else
                Set crg = Union(crg, rg.Cells(rItem, eCols.ecName))
            End If
        End If
    
    Next rItem
    
ProcExit:
    On Error Resume Next
        ' Highlight cells.
        If Not crg Is Nothing Then crg.Interior.Color = vbGreen
        ' Clean up.
        If Not olMail Is Nothing Then Set olMail = Nothing
        If Not olApp Is Nothing Then Set olApp = Nothing
        ' Inform.
        MsgBox IIf(emCount = 0, "No", emCount) & " email" _
            & IIf(emCount = 1, "", "s") & " sent.", _
            IIf(emCount = 0, vbExclamation, vbInformation)
    On Error GoTo 0
Exit Sub

ClearError:
    Debug.Print "Run-time error '" & Err.Number & "':" & Err.Description
    Resume ProcExit
End Sub