Hi,
Really odd one this,
I load unread emails from outlook, works 95% of the time, no error.
From time to time & it seems on emails that are similar, I suspect identical duplicates!
it will crash, array out of bounds.
I am guessing when I mark as read, it then gets confused reading the next email.
I think I can trap the error & carry on & re-read but would like to understand more what's going on.
If I ignore the error & re-run the code, loads the next email fine, I can see Outlook is marking read. I put the msgbox below to delay but fairly sure not this anyway.
Is there a way to see the email UID or whatever its called here?
I will chase my provider (TSOHOST) & try to stop these duplicates, unless something I am doing or perhaps even outlook, I leave outlook running, minimized.
Really odd one this,
I load unread emails from outlook, works 95% of the time, no error.
From time to time & it seems on emails that are similar, I suspect identical duplicates!
it will crash, array out of bounds.
I am guessing when I mark as read, it then gets confused reading the next email.
I think I can trap the error & carry on & re-read but would like to understand more what's going on.
If I ignore the error & re-run the code, loads the next email fine, I can see Outlook is marking read. I put the msgbox below to delay but fairly sure not this anyway.
Is there a way to see the email UID or whatever its called here?
I will chase my provider (TSOHOST) & try to stop these duplicates, unless something I am doing or perhaps even outlook, I leave outlook running, minimized.
Code:
Sub Outlook_ExtractMessages()
Dim oOutlook As Object 'Outlook.Application
Dim oNameSpace As Object 'Outlook.Namespace
Dim oFolder As Object 'Outlook.folder
Dim oItem As Object
Dim oPrp As Object
Const olFolderInbox = 6
Const olMail = 43
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
If Err.Number <> 0 Then 'Could not get instance, so create a new one
Err.Clear
Set oOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo Error_Handler ' Guess wants resume next to get outlook but normal here but while testing turn off
' On Error GoTo 0 ' Turn off error trapping.
' For example, if "\\MyAccount\folder1\subfolder1" is displayed, replace the PickFolder line with:
' Set strFolderName = objNamespace.Folders("MyAccount").Folders("folder1").Folders("subfolder1")
Dim dbs As DAO.Database
Dim r As DAO.Recordset
Dim IsSMS As Boolean
Dim PlainSource As String
Dim SourceShort As String
Dim D1, D2, D3
Dim LoopDates, SplitDates
Dim i As Integer, iFiltered As Integer
Dim AttCount As Integer
Set dbs = CurrentDb
'Open a table-type Recordset
Set r = dbs.OpenRecordset("EmailPasteTable", dbOpenDynaset)
Set oFolder = oNameSpace.Folders("Bookings@fpkennels.com").Folders("inbox") ' .Folders("OlderEmails")
' WORKS Debug.Print oFolder.UnReadItemCount
Dim myItems As Object ' Outlook.items
Dim FilteredItems As Object ' Outlook.items
Dim myItem As Object ' Outlook.MailItem
Set myItems = oFolder.items
Set FilteredItems = myItems.Restrict("[UnRead] = True") '("[Categories] = 'Business'") '("[UnRead] = True")
' Set FilteredItems = oFolder.items ' @@@@@@@ to turn OFF filter @@@@@@@@@
Dim FilteredCount As Integer
FilteredCount = FilteredItems.Count
MsgBox FilteredCount
' if no unread, exit
If FilteredCount = 0 Then GoTo Exit_Outlook_ExtractMessages ' will run if you remove filter above @@@, for ALL
' For Each oItem In oFolder.items ' NB I think goes through ALL in hte inbox, to find unread etc. so delelete old'ish from Imap
For iFiltered = 1 To FilteredCount ' FilteredItems.Count
Set oItem = FilteredItems(iFiltered) ' ######## ERROR - took some finding Array Out Of Bounds SEP 24 #############
' If oItem.UnRead = True Then
With oItem
If .Class = olMail Then
AttCount = .Attachments.Count
r.AddNew
r!Subject = .Subject
r!Source = .HTMLBody
PlainSource = PlainText(r!Source)
r!surname = PickGR(PlainSource, "~s~")(1) ' form textbox if pain so perhaps not needed but anway.
r!MessageID = r!ID
If NullOrEmpty(r!Email) Then r!Email = .senderEmailAddress
r!Received = .receivedTime
r!Source = .HTMLBody
r!tToDo = True ' Chilkat, on import form, top split form, default - was hard to find, not in code
SkipOldDates:
' REMOVED fair bit of code to fit in post, so perhaps messed up if/then etc. may look wring but are OK
r.Update
End If
End With
' End If
oItem.UnRead = False ' mark as read @@@@@@@@@@@ - Do want even with filtered
' MsgBox iFiltered & " : just to slow down, pause really"
Next iFiltered
r.Close
Exit_Outlook_ExtractMessages:
Set oOutlook = Nothing
Set oNameSpace = Nothing
Set oFolder = Nothing
Set oItem = Nothing
Set oPrp = Nothing
Me.Requery
' MsgBox "done"
Error_Handler_Exit:
On Error Resume Next
If Not oPrp Is Nothing Then Set oPrp = Nothing
If Not oItem Is Nothing Then Set oItem = Nothing
If Not oFolder Is Nothing Then Set oFolder = Nothing
If Not oNameSpace Is Nothing Then Set oNameSpace = Nothing
If Not oOutlook Is Nothing Then Set oOutlook = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Outlook_ExtractMessages" & vbCrLf & _
"Error Description: " & Err.DESCRIPTION & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
