Error -2147023719 ‘The operation failed’

R

Risss

New Member
Joined
Feb 22, 2012
Messages
2
Hey<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
<o:p></o:p>
I'm not that well versed in VBA at all so I’m hoping that someone can help!<o:p></o:p>
<o:p> </o:p>
I have found and modified someone else’s code which I found online, unfortunately it doesn’t always work and I’m receiving an error “-2147023719 The operation failed”.<o:p></o:p>
<o:p> </o:p>
The macro starts and runs through a number of times but it randomly stops (Never in the same place though. Sometimes it will retrieve 30 outlook messages and the next time only 5 out of XX).<o:p></o:p>
<o:p> </o:p>
Can anyone tell me what this means and how I might fix this? - Code below.<o:p></o:p>
<o:p> </o:p>
Ta

Code: 
[COLOR=black][FONT=Verdana] 
Option Explicit<o:p></o:p>
Public gblStopProcessing As Boolean<o:p></o:p>
Sub ReadOutlookMessages()<o:p></o:p>
' requires Microsoft Outlook Object Library (Tools/References}<o:p></o:p>
Dim wb As Workbook<o:p></o:p>
Dim ws As Worksheet<o:p></o:p>
Dim wsAudit As Worksheet<o:p></o:p>
Dim wsControl As Worksheet<o:p></o:p>
Dim objFolder As Object<o:p></o:p>
Dim objMsg As Object<o:p></o:p>
Dim objNSpace As Object<o:p></o:p>
'<o:p></o:p>
Dim objOutlook As Outlook.Application<o:p></o:p>
'<o:p></o:p>
Dim blRecordsHaveFormulas As Boolean<o:p></o:p>
Dim blColourCell As Boolean<o:p></o:p>
'<o:p></o:p>
Dim strDelimiter As String<o:p></o:p>
Dim strText As String<o:p></o:p>
Dim lngAuditRecord As Long<o:p></o:p>
Dim lngKount As Long<o:p></o:p>
Dim lngRecordsInEmail As Long<o:p></o:p>
Dim lngRow As Long<o:p></o:p>
Dim lngSaveType As Long ' olTXT save type<o:p></o:p>
Dim lngTotalItems As Long<o:p></o:p>
Dim lngTotalRecords As Long<o:p></o:p>
Dim intFormulasEndColumn As Integer<o:p></o:p>
Dim intFormulasStartColumn As Integer<o:p></o:p>
Dim intFreefile As Integer<o:p></o:p>
Dim intKount As Integer<o:p></o:p>
'<o:p></o:p>
On Error GoTo HandleError<o:p></o:p>
'<o:p></o:p>
    ' Initialise:<o:p></o:p>
     Set wb = ThisWorkbook<o:p></o:p>
     Set wsControl = wb.Worksheets("Control Sheet")<o:p></o:p>
     strDelimiter = wsControl.Range("B3").Value<o:p></o:p>
     blColourCell = False<o:p></o:p>
     lngAuditRecord = 1 ' Start row<o:p></o:p>
     lngSaveType = 0 ' save as .txt<o:p></o:p>
     lngTotalRecords = 0<o:p></o:p>
'<o:p></o:p>
    ' Read email messages:<o:p></o:p>
     Application.ScreenUpdating = False<o:p></o:p>
     Set objOutlook = CreateObject("Outlook.Application")<o:p></o:p>
     Set objNSpace = objOutlook.GetNamespace("MAPI")<o:p></o:p>
'<o:p></o:p>
    ' Allow user to choose folder:#<o:p></o:p>
     Set objFolder = objNSpace.pickfolder<o:p></o:p>
    ' Check if cancelled:<o:p></o:p>
     If objFolder Is Nothing Then<o:p></o:p>
         gblStopProcessing = True<o:p></o:p>
         MsgBox "Processing cancelled"<o:p></o:p>
        Exit Sub<o:p></o:p>
    End If<o:p></o:p>
'<o:p></o:p>
     lngTotalItems = objFolder.Items.Count<o:p></o:p>
     If lngTotalItems = 0 Then<o:p></o:p>
         MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder"<o:p></o:p>
         gblStopProcessing = True<o:p></o:p>
        GoTo HandleExit<o:p></o:p>
    End If<o:p></o:p>
     If lngTotalItems > 0 Then<o:p></o:p>
         On Error Resume Next<o:p></o:p>
             Application.DisplayAlerts = False<o:p></o:p>
             wb.Worksheets("Merge Data").Delete<o:p></o:p>
             wb.Worksheets("Audit").Delete<o:p></o:p>
             Application.DisplayAlerts = True<o:p></o:p>
         On Error GoTo HandleError<o:p></o:p>
         wb.Worksheets.Add After:=Worksheets(Worksheets.Count)<o:p></o:p>
         Set ws = ActiveSheet<o:p></o:p>
         ws.name = "Merge Data"<o:p></o:p>
         wb.Worksheets.Add After:=Worksheets(Worksheets.Count)<o:p></o:p>
         Set wsAudit = ActiveSheet<o:p></o:p>
         wsAudit.name = "Audit"<o:p></o:p>
         wsAudit.Range("A1") = "Email data imported on " & Now()<o:p></o:p>
         lngAuditRecord = lngAuditRecord + 1<o:p></o:p>
         wsAudit.Cells(lngAuditRecord, 1) = "Subject"<o:p></o:p>
         wsAudit.Cells(lngAuditRecord, 2) = "Sender's Email Address"<o:p></o:p>
         wsAudit.Cells(lngAuditRecord, 3) = "Email Creation Time"<o:p></o:p>
         wsAudit.Cells(lngAuditRecord, 4) = "Email Received Time"<o:p></o:p>
         wsAudit.Cells(lngAuditRecord, 5) = "Records Imported"<o:p></o:p>
         wsAudit.Range(Cells(lngAuditRecord, 1), Cells(lngAuditRecord, 1)).Select<o:p></o:p>
         Selection.EntireRow.Font.Bold = True<o:p></o:p>
         Selection.HorizontalAlignment = xlCenter<o:p></o:p>
         lngAuditRecord = lngAuditRecord + 1<o:p></o:p>
         ws.Activate<o:p></o:p>
         lngRow = 1 ' start row in worksheet "Merge Data"<o:p></o:p>
         For lngKount = 1 To lngTotalItems<o:p></o:p>
             Application.StatusBar = "Reading message " & lngKount & " of " & lngTotalItems<o:p></o:p>
             Set objMsg = objFolder.Items(lngKount)<o:p></o:p>
             objMsg.SaveAs "U:\temp333.txt", lngSaveType<o:p></o:p>
             Close<o:p></o:p>
             intFreefile = FreeFile<o:p></o:p>
             Open "U:\temp333.txt" For Input As #intFreefile<o:p></o:p>
             lngRecordsInEmail = 0<o:p></o:p>
             Do Until EOF(intFreefile)<o:p></o:p>
                 Line Input #intFreefile, strText<o:p></o:p>
                 If InStr(1, strText, strDelimiter) > 0 Then<o:p></o:p>
                     ws.Cells(lngRow, 1).Value = strText<o:p></o:p>
                     If blColourCell Then<o:p></o:p>
                         ws.Cells(lngRow, 1).Interior.ColorIndex = 35<o:p></o:p>
                    End If<o:p></o:p>
                     lngRow = lngRow + 1<o:p></o:p>
                    lngTotalRecords = lngTotalRecords + 1<o:p></o:p>
                     lngRecordsInEmail = lngRecordsInEmail + 1<o:p></o:p>
                End If<o:p></o:p>
             Loop<o:p></o:p>
             Close<o:p></o:p>
            ' switch cell colouring:<o:p></o:p>
             blColourCell = Not blColourCell<o:p></o:p>
'<o:p></o:p>
' Update Audit record:<o:p></o:p>
             On Error Resume Next<o:p></o:p>
             wsAudit.Activate<o:p></o:p>
             wsAudit.Cells(lngAuditRecord, 1) = objFolder.Items(lngKount).Subject<o:p></o:p>
             wsAudit.Cells(lngAuditRecord, 2) = objFolder.Items(lngKount).SenderEmailAddress<o:p></o:p>
             wsAudit.Cells(lngAuditRecord, 3) = objFolder.Items(lngKount).CreationTime<o:p></o:p>
             wsAudit.Cells(lngAuditRecord, 4) = objFolder.Items(lngKount).ReceivedTime<o:p></o:p>
             wsAudit.Cells(lngAuditRecord, 5) = lngRecordsInEmail<o:p></o:p>
             wsAudit.Range("A1").Select<o:p></o:p>
             wsAudit.Cells.Columns.AutoFit<o:p></o:p>
             lngAuditRecord = lngAuditRecord + 1<o:p></o:p>
             On Error GoTo HandleError<o:p></o:p>
'<o:p></o:p>
             ws.Activate<o:p></o:p>
        Next lngKount<o:p></o:p>
         Kill ThisWorkbook.Path & "\temp333.txt"<o:p></o:p>
   End If<o:p></o:p>
'<o:p></o:p>
' Check that records have been found:<o:p></o:p>
     If lngTotalRecords = 0 Then<o:p></o:p>
         MsgBox "No records were found for import", vbOKOnly + vbCritical, "Error - no records found"<o:p></o:p>
         gblStopProcessing = True<o:p></o:p>
        GoTo HandleExit<o:p></o:p>
    End If<o:p></o:p>
<o:p> </o:p>
HandleExit:<o:p></o:p>
     On Error Resume Next<o:p></o:p>
     Application.ScreenUpdating = True<o:p></o:p>
     Set objNSpace = Nothing<o:p></o:p>
     Set objFolder = Nothing<o:p></o:p>
     Set objMsg = Nothing<o:p></o:p>
     Set objOutlook = Nothing<o:p></o:p>
     Set ws = Nothing<o:p></o:p>
     Set wsAudit = Nothing<o:p></o:p>
     Set wsControl = Nothing<o:p></o:p>
     Set wb = Nothing<o:p></o:p>
'<o:p></o:p>
     If Not gblStopProcessing Then<o:p></o:p>
            MsgBox "Processing completed" & vbCrLf & vbCrLf & _<o:p></o:p>
               "Please check results", vbOKOnly + vbInformation, "Information"<o:p></o:p>
    End If<o:p></o:p>
'<o:p></o:p>
    Exit Sub<o:p></o:p>
'<o:p></o:p>
HandleError:<o:p></o:p>
    MsgBox Err.Number & vbCrLf & Err.Description<o:p></o:p>
    gblStopProcessing = True<o:p></o:p>
    Resume HandleExit<o:p></o:p>
    <o:p></o:p>
End Sub<o:p></o:p>
[/FONT][/COLOR]
<o:p></o:p>
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Code: 
Dim objOutlook As Outlook.Application
What is this?


Your code is kind of hard to follow, with all the variables, but I don't see anything particularly wrong with it other than the above. Outlook.Application is not a data type that I'm aware of.
 
Upvote 0
welcome to the board


i have had errors like this occur with looped internet queries. when i went to xl2010 they all disappeared.. make of it as you will. i cant explain.
 
Upvote 0
Hi diddi and jproffer,

Thank you both for your speedy replies.

I don't know why but I removed the below line from the code and it has worked twice this morning!!

Code: 
 Kill ThisWorkbook.Path & "\temp333.txt"

Again, thank you!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
code hangs up but if I ESC out of it, it finished????
Replies
6
Views
524
RCBricker
R
S
  • Question Question
Outlook Email Content to Excel (VBA)
Replies
5
Views
25K
SerenityNetworks
S
E
  • Question Question
Reading from Outlook body to Excel spreadhseet returns blank values with VBA
Replies
3
Views
4K
gardnertoo
gardnertoo
R
  • Question Question
Variable amount = user input minus 2????
Replies
2
Views
375
RCBricker
R

Forum statistics

Threads
1,223,958
Messages
6,175,636
Members
452,662
Latest member
Aman1997

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top