none
Catastrophic Failure with CreateObject("Outlook.Application") in Access2013 RRS feed

  • Question

  • I am trying to create an outlook email to send with multiple attachments, but I keep getting a catastrophic error when the VBA code in Microsoft Access gets to the CreateObject("Outlook.Application") line. Why is this happening? What do I need to do to get this to work? I have Microsoft Outlook 15.0 Object Library reference included.  Here is my code:

    Private Sub cmdDoBulkEmails2_Click()
    On Error GoTo Err_cmdDoBulkEmails2_Click

    Dim con As ADODB.Connection

    Dim objOL As Object
    Set objOL = CreateObject("Outlook.Application")


    Dim rsMembers As ADODB.Recordset
    Dim MembersCriteria As String
    Dim strEmail As String
    Dim strSubject As String
    Dim strIssue As String
    Dim strNewsletterBody As String
    Dim strSeminarBody As String
    Dim strBody As String
    Dim strOther As String
    Dim strTo As String
    Dim strBCC As String
    Dim sttBCCList As StreamReadEnum
    Dim strItems As String
    Dim n As Integer

    Dim ctlSource As Control
    Dim strItemsAttch As String
    Dim intCurrentRowAttch As Integer

    Dim RecCount As Long
    Dim MemCount As Long
    Dim RemainCount As Long

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    Set oFile = fso.CreateTextFile(Me.txtEmailSentPath)

    Set ctlSource = Me.lbAttachment

        Set con = Application.CurrentProject.Connection
          
        Set rsMembers = New ADODB.Recordset
        rsMembers.CursorType = adOpenKeyset
        rsMembers.LockType = adLockOptimistic
        
        MembersCriteria = "Select * from TestMembers"
        rsMembers.Open MembersCriteria, con, 1    ' 1 = adOpenKeyset

        Set objNS = objOL.GetNameSpace("MAPI")
        strSubject = Me.txtSubject
        strBody = Me.txtBody
        strTo = Me.txtTo        
        strBCC = ""
        strItems = ""
       
         If Not rsMembers.EOF Then
            rsMembers.MoveFirst
            RecCount = rsMembers.RecordCount
            MemCount = 0
            Do While Not rsMembers.EOF
                Set MyItem = objOL.CreateItem(olMailItem)
                Set MyAttachments = MyItem.Attachments

                MyItem.TO = strTo
                MyItem.Subject = strSubject
                MyItem.Body = strBody
     
                For intCurrentRowAttch = 0 To ctlSource.ListCount - 1
                    If ctlSource.Selected(intCurrentRowAttch) Then
                        strItems = ctlSource.Column(3, intCurrentRowAttch)
                        MyAttachments.Add strItems
                        strItems = ""
                    End If
                Next intCurrentRowAttch
                If Not rsMembers.EOF Then
                    rsMembers.MoveFirst
                    RecCount = rsMembers.RecordCount
                    MemCount = 0
                    Set MyItem = objOL.CreateItem(olMailItem)
                    Set MyAttachments = MyItem.Attachments

                    MyItem.TO = strTo
                    MyItem.Subject = strSubject
                    MyItem.Body = strBody
     
                    For intCurrentRowAttch = 0 To ctlSource.ListCount - 1
                        If ctlSource.Selected(intCurrentRowAttch) Then
                            strItems = ctlSource.Column(3, intCurrentRowAttch)
                            MyAttachments.Add strItems
                            strItems = ""
                        End If
                    Next intCurrentRowAttch
     
                    MyItem.TO = strTo
                    RemainCount = RecCount - MemCount
                    For n = 1 To IIf(RemainCount > 20, 20, RemainCount)
                        strEmail = Nz(rsMembers![E-MAIL_ADD], "")
     
                        If strEmail <> "" Then
                            strBCC = strBCC + strEmail + "; "
                        End If
                        If Not rsMembers.EOF Then
                            rsMembers.MoveNext
                            MemCount = MemCount + 1
                        End If
                    Next n
                    If strBCC <> "" Then
                        MyItem.BCC = strBCC
                        oFile.WriteLine strBCC
                       
                        MyItem.Send
                   
                        strBCC = ""
                    End If
                End If
            Loop
        End If

     MsgBox "We are done.  Refresh your emails."

    rsMembers.Close
    Set ctlSource = Nothing
    oFile.Close
    Set oFile = Nothing
    Set fso = Nothing

    Set MyAttachments = Nothing
    Set MyItem = Nothing
    Set objNS = Nothing
    Set objOL = Nothing
    Set con = Nothing
     
    Exit_cmdDoBulkEmails2_Click:
        Exit Sub

    Err_cmdDoBulkEmails2_Click:
       
        'MsgBox Err.Description
        MsgBox "Automation Error " & vbCr & Err.Number & _
               " (" & Hex(Err.Number) & ")" & Err.Description
    '    Resume Next
        Resume Exit_cmdDoBulkEmails2_Click

    End Sub

    Saturday, November 21, 2015 5:26 PM

Answers

All replies

  • Hello Debbie,

    I suspect that you are wondering why no one has responded to your post...  I think I can safely say that you have baffled everyone with what you have going on here.  There are a number of problems with your code including major unnecessary redundancies, infinite looping, among many other issues.

    I'm not sure if I have a full grip on what you're trying to accomplish.  However, I have rewritten your code and I am providing the revised work here for you to test and determine suitability for your requirements.

    I hope that this helps you out. 

    Best Regards,

    RM

    Private Sub cmdDoBulkEmails2_Click()
        
        SendBulkEmail Me.txtEmailSentPath, Me.txtSubject, Me.txtBody, Me.txtTo, Me.lbAttachment
        
    End Sub
    
    Function SendBulkEmail(EmailSentPath As String, EmailSubject As String, EmailBody As String, EmailTo As String, lbxAttachments As Control) As Long
        
        On Error GoTo Err_Process
    
        Dim objFSO As Object
        Dim objFile As Object
        Dim rst1 As DAO.Recordset
        Dim strMsg As String
        Dim strSQL As String
        Dim strSubject As String
        Dim strBody As String
        Dim strTo As String
        Dim strBCC As String
        Dim strBuf As String
        Dim strAttachments As String
        Dim intCount As Integer
        Dim lngReturn As Long
        Dim lngRecordCount As Long
        Dim blnStatus As Boolean
    
        lngReturn = 0
    
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objFile = objFSO.CreateTextFile(EmailSentPath)
    
        strSQL = "SELECT * FROM TestMembers;"
        Set rst1 = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
    
        strSubject = EmailSubject
        strBody = EmailBody
        strTo = EmailTo
        strBCC = ""
    
        For intCount = 0 To lbxAttachments.ListCount - 1
            If lbxAttachments.Selected(intCount) Then
                If (strAttachments <> "") Then
                    strAttachments = strAttachments & ";"
                End If
                strAttachments = strAttachments & lbxAttachments.Column(3, intCount)
            End If
        Next intCount
    
        intCount = 0
        With rst1
            If (Not .EOF) Then
                .MoveLast
                .MoveFirst
                lngRecordCount = .RecordCount
            End If
            
            Do While Not rst1.EOF
                intCount = intCount + 1
                
                strBuf = Nz(rst1![E-MAIL_ADD], "")
        
                If strBuf <> "" Then
                    If (strBCC <> "") Then
                        strBCC = strBCC & ";"
                    End If
                    strBCC = strBCC & strBuf
                End If
                
                If (strBCC <> "" And (intCount > 19 Or .AbsolutePosition + 1 = lngRecordCount)) Then
                    objFile.WriteLine strBCC
                    blnStatus = OutlookSendMessage(strTo, "", strBCC, strSubject, strBody, strAttachments)
                    If (blnStatus) Then
                        lngReturn = lngReturn + 1
                    End If
                    intCount = 0
                    strBCC = ""
                End If
                .MoveNext
            Loop
        End With
        
        If (lngReturn > 0) Then
            strMsg = lngReturn & " emails have been sent." & vbCrLf & vbCrLf & "Please refresh your email list."
            MsgBox strMsg, vbInformation, "Process Complete"
        End If
    
        rst1.Close
        objFile.Close
    
    Exit_Process:
        Set objFile = Nothing
        Set objFSO = Nothing
    Set rst1 = Nothing SendBulkEmail = lngReturn Exit Function Err_Process: MsgBox_Error "SendBulkEmail" Resume Exit_Process End Function Function OutlookSendMessage(ToRecipients, Optional CCRecipients, Optional BCCRecipients, Optional MsgSubject, Optional MsgBody, Optional AttachmentPath, Optional AttachmentName, Optional Importance As OlImportance = olImportanceNormal) As Boolean On Error GoTo Err_Process Dim objOutlook As Outlook.Application Dim objMailItem As Outlook.MailItem Dim objRecipient As Outlook.Recipient Dim objAttachment As Outlook.Attachment Dim strArray() As String Dim strToken As String Dim strMsg As String Dim lngPos As Long Dim blnReturn As Boolean blnReturn = False If (Nz(ToRecipients, "") <> "") Then 'Create the Outlook session. Set objOutlook = CreateObject("Outlook.Application") 'Create the message. Set objMailItem = objOutlook.CreateItem(olMailItem) With objMailItem 'Add the To recipient(s) to the message. strArray = Split(ToRecipients, ";") For lngPos = 0 To UBound(strArray) strToken = Trim(strArray(lngPos)) If (strToken <> "") Then Set objRecipient = .Recipients.Add(strToken) objRecipient.Type = olTo End If Next If (Not IsMissing(CCRecipients)) Then If (Nz(CCRecipients, "") <> "") Then 'Add the CC recipient(s) to the message. strArray = Split(CCRecipients, ";") For lngPos = 0 To UBound(strArray) strToken = Trim(strArray(lngPos)) If (strToken <> "") Then Set objRecipient = .Recipients.Add(strToken) objRecipient.Type = olCC End If Next End If End If If (Not IsMissing(BCCRecipients)) Then If (Nz(BCCRecipients, "") <> "") Then 'Add the CC recipient(s) to the message. strArray = Split(BCCRecipients, ";") For lngPos = 0 To UBound(strArray) strToken = Trim(strArray(lngPos)) If (strToken <> "") Then Set objRecipient = .Recipients.Add(strToken) objRecipient.Type = olBCC End If Next End If End If 'Set the Subject, Body, and Importance of the message. If (Not IsMissing(MsgSubject)) Then .Subject = Nz(MsgSubject, "") If (Not IsMissing(MsgBody)) Then .Body = Nz(MsgBody, "") .Importance = Importance .BodyFormat = olFormatHTML 'Add attachments to the message. If Not IsMissing(AttachmentPath) Then Set objAttachment = .Attachments.Add(CStr(AttachmentPath), , , CStr(Nz(AttachmentName, ""))) End If 'Resolve each Recipient's name. For Each objRecipient In .Recipients If Not objRecipient.Resolve Then .Display End If Next .Send blnReturn = True End With End If Exit_Process: Set objMailItem = Nothing Set objOutlook = Nothing Set objRecipient = Nothing Set objAttachment = Nothing OutlookSendMessage = blnReturn Exit Function Err_Process: Select Case Err Case 287 strMsg = "You clicked No to the Outlook security warning. " & _ "Rerun the procedure and click Yes to access e-mail" & _ "addresses to send your message. For more information, " & _ "see the document at http://www.microsoft.com/office" & _ "/previous/outlook/downloads/security.asp." MsgBox strMsg, vbExclamation, "Error" Case Else MsgBox_Error "OutlookSendMessage" End Select Resume Exit_Process End Function Sub MsgBox_Error(Optional ProcName As String, Optional ModuleName As String) Dim strMsg As String strMsg = "Error:" & vbTab & vbTab & Err.Number If (ModuleName <> "") Then strMsg = strMsg & vbCrLf & "Module:" & vbTab & vbTab & ModuleName End If If (ProcName <> "") Then strMsg = strMsg & vbCrLf & "Procedure:" & vbTab & ProcName End If strMsg = strMsg & vbCrLf & vbCrLf & Err.Description MsgBox strMsg, vbExclamation, "Error" End Sub





    Sunday, November 22, 2015 3:22 AM
  • Thank you for rewriting the code.  I hadn't considered the fact that I should isolate the creation of the outlook.application to be created for each new email generated.  The code works fine.  However, I am still getting the Automation Error Catastrophic failure in procedure OutlookSendMessage with error number -2147418113. So, the email is never created.  I'm beginning to believe that there is some problem with Outlook's ability to receive the VBA calls to create the emails. What would you suggest I do?

    Thanks again for your help!

    Debbie

    Sunday, November 22, 2015 7:36 AM
  • Hi Debbie,

    >> I am still getting the Automation Error Catastrophic failure in procedure OutlookSendMessage with error number -2147418113.

    Did you mean you get this error in this line “Set objOutlook = CreateObject("Outlook.Application")”?
    I suggest you open you outlook manually to check whether you could send a mail.

    If you could not, it would be better if you could share us the errors. If you could, I suggest you try to use early binding. You could refer the link below for more information.

    # Automating Outlook from a Visual Basic Application
    https://msdn.microsoft.com/en-us/library/office/ff865816.aspx?f=255&MSPPError=-2147217396

    In addition, I suggest you test the simple code below to check whether you still get this error.

    Dim objOL as Object 
    Set objOL = CreateObject("Outlook.Application")

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Monday, November 23, 2015 8:06 AM
  • Yes, I get this error in this line “Set objOutlook = CreateObject("Outlook.Application").  Yes, I can manually send an Outlook mail ok.  This error is happening on my laptop when is Windows 8.1 with Office 365.  When I copy the database to my desktop which is Windows Vista Home Premium and Microsoft Office Professional 2007, I get different error.  I must note that my emails seemed be home to my desktop and secondary to my laptop on refresh only.

    On desktop for each recipient, I get a prompt to allow email to be generated (my antivirus is current, but for some reason Outlook doesn't think it's active and continues to prompt for each recipient).  So I keep allowing the email to be generated.  Then when it gets to the line to Set objAttachment = .Attachments.Add(CStr(AttachmentPath),,,CStr(NZ(AttachmentName, ""))) it errors out because AttachmentPath contains full path and file name for every attachment while AttachmentName is null.  So I tried parsing out the path separately from the name for each attachment and one at a time use this line of code to add a single attachment at a time instead of all attachments at once.  Still don't have it right.   Don't know if this is related to Catastrophic error on my laptop or not.  I can send/receive emails on my laptop as well manually.

    Any other ideas? or suggestions to fix what is wrong?

    Debbie

    Tuesday, November 24, 2015 2:29 AM
  • Hi Debbie,

    Based on your description, did you mean this“Set objOutlook = CreateObject("Outlook.Application")” would not generate error in your pc? If so, I assume your original error might be caused by office broken.

    I suggest you repair your Office, and try again. If you still get this error, I would suggest you uninstall/install your Office.

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Tuesday, November 24, 2015 5:35 AM
  • Hello Debbie,

    I think your first problem that you need to overcome is trying to develop your system between different environments and Access versions.  Every time you open your file on a different machine with a different environment, Access will try to adjust the references.  Unfortunately, it isn't always successful.  That will cause certain problems in your code.  That brings me to your next problem...

    It sounds like you may not have a reference set up appropriately if the code fails on the "Set" line.  I get the idea that you may not be compiling your code before you attempt to run it either, because your original code had numerous issues.  Check your references and be sure that you're up to date on whatever machine your developing on.  Then compile your code to ensure that everything compiles without issue.  Make any corrections where necessary.  Then walk through your code one line at a time by pressing F8.  You can begin by launching your code from your button with a breakpoint set at the first line.  Then just walk through until you reach the end.  If you encounter an error in between, trace the source of the problem down, correct it, then repeat your walk until you've successfully completed your procedure(s).  This is called debugging.  We can't do it for you since we don't have your equipment or your application to test.

    As for your problem with the Attachments, it should not have anything to do with the file existing in the file path.  See the following:

    expression  .Add(Source, Type, Position, DisplayName)

    expression   A variable that represents an Attachments object.

    Parameters

    Name

    Required/Optional

    Data Type

    Description

    Source

    Required

    Variant

    The source of the attachment. This can be a file (represented by the full file system path with a file name) or an Outlook item that constitutes the attachment.

    Type

    Optional

    Long

    The type of the attachment. Can be one of the OlAttachmentType constants.

    Position

    Optional

    Long

    This parameter applies only to e-mail messages using the Rich Text format: it is the position where the attachment should be placed within the body text of the message. A value of 1 for the Position parameter specifies that the attachment should be positioned at the beginning of the message body. A value 'n' greater than the number of characters in the body of the e-mail item specifies that the attachment should be placed at the end. A value of 0 makes the attachment hidden.

    DisplayName

    Optional

    String

    This parameter applies only if the mail item is in Rich Text format and Type is set to olByValue: the name is displayed in an Inspector object for the attachment or when viewing the properties of the attachment. If the mail item is in Plain Text or HTML format, then the attachment is displayed using the file name in the Source parameter.

    Return Value

    An  Attachment   object that represents the new attachment.

    For more information on the Attachment object, see the following:

    https://msdn.microsoft.com/en-us/library/office/ff869553.aspx?f=255&MSPPError=-2147217396

    I have updated the procedure "OutlookSendMessage."  See below:

    Function OutlookSendMessage(ToRecipients, Optional CCRecipients, Optional BCCRecipients, Optional MsgSubject, Optional MsgBody, Optional AttachmentPaths, Optional AttachmentNames, Optional Importance As OlImportance = olImportanceNormal) As Boolean
       
        On Error GoTo Err_Process
        
        Dim objOutlook As Outlook.Application
        Dim objMailItem As Outlook.MailItem
        Dim objRecipient As Outlook.Recipient
        Dim objAttachments As Outlook.Attachments
        Dim strArray() As String
        Dim strArray2() As String
        Dim strToken As String
        Dim strToken2 As String
        Dim blnStatus As Boolean
        Dim strMsg As String
        Dim lngPos As Long
        Dim blnReturn As Boolean
        
        blnReturn = False
    
        If (Nz(ToRecipients, "") <> "") Then
            'Create the Outlook session.
            Set objOutlook = CreateObject("Outlook.Application")
    
            'Create the message.
            Set objMailItem = objOutlook.CreateItem(olMailItem)
    
            With objMailItem
                'Add the To recipient(s) to the message.
                strArray = Split(ToRecipients, ";")
                For lngPos = 0 To UBound(strArray)
                    strToken = Trim(strArray(lngPos))
                    If (strToken <> "") Then
                        Set objRecipient = .Recipients.Add(strToken)
                        objRecipient.Type = olTo
                    End If
                Next
    
                If (Not IsMissing(CCRecipients)) Then
                    If (Nz(CCRecipients, "") <> "") Then
                        'Add the CC recipient(s) to the message.
                        strArray = Split(CCRecipients, ";")
                        For lngPos = 0 To UBound(strArray)
                            strToken = Trim(strArray(lngPos))
                            If (strToken <> "") Then
                                Set objRecipient = .Recipients.Add(strToken)
                                objRecipient.Type = olCC
                            End If
                        Next
                    End If
                End If
    
                If (Not IsMissing(BCCRecipients)) Then
                    If (Nz(BCCRecipients, "") <> "") Then
                        'Add the CC recipient(s) to the message.
                        strArray = Split(BCCRecipients, ";")
                        For lngPos = 0 To UBound(strArray)
                            strToken = Trim(strArray(lngPos))
                            If (strToken <> "") Then
                                Set objRecipient = .Recipients.Add(strToken)
                                objRecipient.Type = olBCC
                            End If
                        Next
                    End If
                End If
    
                'Set the Subject, Body, and Importance of the message.
                If (Not IsMissing(MsgSubject)) Then .Subject = Nz(MsgSubject, "")
                If (Not IsMissing(MsgBody)) Then .Body = Nz(MsgBody, "")
    
                .Importance = Importance
                .BodyFormat = olFormatHTML
    
                'Add attachments to the message.
                If Not IsMissing(AttachmentPaths) Then
                    Set objAttachments = .Attachments
                    If (Nz(AttachmentPaths, "") <> "") Then
                        strArray = Split(AttachmentPaths, ";")
                        blnStatus = False
                        If (Nz(AttachmentNames, "") <> "") Then
                            strArray2 = Split(AttachmentNames, ";")
                            blnStatus = UBound(strArray2) = UBound(strArray)
                        End If
                        For lngPos = 0 To UBound(strArray)
                            strToken = Trim(strArray(lngPos))
                            If (strToken <> "") Then
                                If (Not blnStatus) Then
                                    objAttachments.Add strToken
                                Else
                                    strToken2 = Trim(strArray2(lngPos))
                                    objAttachments.Add strToken, , , strToken2
                                End If
                            End If
                        Next
                    End If
                End If
    
                'Resolve each Recipient's name.
                For Each objRecipient In .Recipients
                    If Not objRecipient.Resolve Then
                        .Display
                    End If
                Next
              .Send
              blnReturn = True
            End With
        End If
    
    Exit_Process:
        Set objMailItem = Nothing
        Set objOutlook = Nothing
        Set objRecipient = Nothing
        Set objAttachments = Nothing
    
        OutlookSendMessage = blnReturn
        Exit Function
    
    Err_Process:
        Select Case Err
        Case 287
            strMsg = "You clicked No to the Outlook security warning. " & _
            "Rerun the procedure and click Yes to access e-mail" & _
            "addresses to send your message. For more information, " & _
            "see the document at " & _
            "http://www.microsoft.com/office/previous/outlook/downloads/security.asp."
            
            MsgBox strMsg, vbExclamation, "Error"
        Case Else
            MsgBox_Error "OutlookSendMessage"
        End Select
        Resume Exit_Process
        
    End Function
    

    • Edited by RunningManHD Tuesday, November 24, 2015 11:14 PM
    Tuesday, November 24, 2015 11:08 PM
  • I am well aware of the differences in references between Microsoft Office versions, I have no problem setting them or debugging code.  I just can't seem to get beyond the original error message:  Catastrophic Failure on the laptop (newer version).  I did finally manage to get the code to run in the desktop version (older version). 

    This leads me to believe that Outlook on my laptop must be corrupt or there is some setting preventing programmatic access to outlook that I haven't already tried.  I have insured that I have the latest Office updates.  When I go to the outlook profile and try to repair it initially, there is a problem connecting to server.  Yet, I can successfully send a test message and Finish.  With all that said, I can create/send/receive email messages in Outlook just fine.  It's only having an issue when I try to create an email from code.

    Thanks for all the helpful code.  I really appreciate it. I didn't have a good understanding of the outlook model and properties before and was struggling to pull it together.  Now I understand it much better.  Just wish I could solve the problem on my laptop, so I can complete testing the code on the newer versions.

    Debbie

    Wednesday, November 25, 2015 4:23 AM
  • Hi Debbie,

    >> When I go to the outlook profile and try to repair it initially, there is a problem connecting to server

    What do you mean with “outlook profile”? For repairing Office, you need to go to control panel.
    # Repair an Office application
    https://support.office.com/en-NZ/Article/Repair-an-Office-application-7821d4b6-7c1d-4205-aa0e-a6b40c5bb88b

    >> It's only having an issue when I try to create an email from code.

    At present, you test your code in access, am I right? If so, I suggest you tried the simple code below in Outlook to check whether it could work.

    Sub test1()
    Dim objOL As Object
    Set objOL = CreateObject("Outlook.Application")
    End Sub

    In addition, have your tried early binding in my above reply?

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Thursday, November 26, 2015 8:51 AM
  • I finally upgraded the laptop to Windows 10 and reinstalled Office 365 which also upgraded to Access to 2016.  I ran the code and everything works again.  Yeah!!!!

    Debbie

    Saturday, November 28, 2015 6:27 AM
  • Hi Debbie,

    I am glad your issue has been resolved, I suggest you mark the solution as answer to close this thread.

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Monday, November 30, 2015 2:41 AM