VBA Application-defined error outlook connection-CodePudding

I have the following code and keep having the error "application-defined or object-defined error" and cannot understand why. The tool Microsoft Office 16.0 Object library is activated, I am confident that the error is liked with the line Set outlookMail = outlookApp.CreateItem(0). For sure I am missing something in the connection with 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

CodePudding user response：

The tool Microsoft Office 16.0 Object library is activated

I suppose you have added a reference to the Outlook object model (a COM reference) in Excel VBA environment. In the code I see that the late-binding technology is used:

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

But at the same time you added a COM object reference for using the early-binding in the code. So, I'd suggest using the New operator and declare all Outlook objects in the code with specific types instead:

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

Set outlookApp = New Outlook.Application()

You can read more about early and late binding technologies in the Using early binding and late binding in Automation article.

CodePudding user response：

Send Emails From 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