Run time error 91, code was working before now it isn't? - vba

My code is supposed to check my inbox for unopened emails that contain csv files. When it encounters one it is supposed to download it with a new name and mark the email as read in a new folder.
Everything was working yesterday and now I am getting a run-time error 91.
Option Explicit
Sub SaveAttachments()
Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim avDate() As String
Dim vDate As String
Dim Address As String
Dim i As Long
Dim j As Long
Dim csvCount As Long
Dim myDestFolder As Outlook.MAPIFolder
Const myPath As String = "C:\Saved CSV\"
ReDim Preserve avDate(3)
Set myOlapp = CreateObject("Outlook.Application")
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
i = 0
j = 0
Set myDestFolder = myFolder.Parent.Folders("CSV Emails")
For i = myFolder.Items.Count To 1 Step -1
If TypeName(myFolder.Items(i)) = "MailItem" Then
Set myItem = myFolder.Items(i)
End If
csvCount = 0
If myItem.UnRead = True Then 'Run time error Here'
avDate = Split(CStr(myItem.ReceivedTime), "/")
vDate = Mid(avDate(2), 1, 4) & "-" & avDate(1) & "-" & avDate(0)
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments
If LCase(Right(myAttachment.FileName, 3)) = "csv" Then
j = j + 1
csvCount = csvCount + 1
Dim recipientsItem As Object
Dim OldMessage As Outlook.MailItem
Set OldMessage = ActiveExplorer.Selection.Item(1)
For Each recipientsItem In OldMessage.Recipients
If OldMessage.SenderEmailType = "EX" Then
Address = OldMessage.Sender.GetExchangeUser.PrimarySmtpAddress
End If
If OldMessage.SenderEmailType = "SMTP" Then
Address = mymessage.SenderEmailAddress
End If
Next recipientsItem
myAttachment.SaveAsFile ((myPath) & "," & Address & "," & vDate & " - " & j & " - " & myAttachment.FileName)
End If
Next myAttachment
If csvCount > 0 Then
myItem.UnRead = False
myItem.Move myDestFolder
End If
End If
End If
Next i
SaveAttachments_exit:
Set myAttachment = Nothing
Set myItem = Nothing
Set myNameSpace = Nothing
Set OldMessage = Nothing
Exit Sub
SaveAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachments_exit
End Sub
I am getting an error on
If myItem.UnRead = True Then
Didn't have the error yesterday. Any help would be appreciated.
I am assuming that it is because the set statement for myItem is within the for loop and it isn't being set properly.
For anyone wondering why I am putting commas in the file name it is so I can extract the senders email address with a -split statement in powershell.

My suspect is that this line Set myItem = myFolder.Items(i) is never executed, and this will cause your If instruction to fail accessing the object property.
This can be caused by several reason:
Outlook doesn't return any mail (Items.Count = 0)
Your If condition is never satisfied (TypeName(myFolder.Items(i)) is never "MailItem")
Your default mailbox is changed, and doesn't contain any MailBox Item.
Technical problems (i.e Can't instantiate an instance of Outlook, Different version of Office, etc.)
Finding the error
To test which of this problem can be, I suggest you to run the code in debug mode and executing each instruction step-by-step (you can do it by pressing F8).
While still executing the code, check the value of your variables (using your Local Variable Window).
This can help you better understanding what's going on with your code, and can be a great help in finding where is the issue.
Check if the object is Not Null
In any case, it's a good practice to check if the object is initialized, before trying accessing it.
To do that, you can add this instruction:
If Not myItem Is Nothing then
If myItem.UnRead = True Then
'rest of your code...
Hope this helps.

Related

How to bypass Outlook item that generates an error when replying to mail using Excel VBA?

I have working code that replies to an email in the user's Outlook, based on the subject. If the most recent item is a meeting invite, my code will not retrieve the email I want. Instead it will not pass the meeting invite and will display an error.
Code is as follows.
Sub Display()
Dim Fldr As Outlook.Folder
Dim olfolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim i As Integer
Dim signature As String
Set Fldr = Session.GetDefaultFolder(olFolderInbox)
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.Count
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olMail = olItems(i)
If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
If Not olMail.Categories = "Executed" Then
Set olReply = olMail.ReplyAll
With olReply
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & "<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & "Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next i
End Sub
Is it possible to bypass the most recent item if the code will not pass the first email. Example: Meeting Invite
Dim olMail As Outlook.MailItem
...
Set olMail = olItems(i)
That Set assignment will not only fail if the first item is a meeting invite, it will fail for any olItems(i) (i.e. any value of i) that is not an Outlook.MailItem instance. That includes anything that can possibly land into an Outlook inbox, including a meeting invite.
One way to go would be to handle the runtime error that's thrown in the specific case where olItems(i) isn't a MailItem:
For i = 1 To olItems.Count
On Error GoTo ErrHandler ' jumps to error-handling subroutine if there's an error
Set olMail = olItems(i)
On Error GoTo 0 ' let any other error blow everything up
...
SkipToNext:
Next i
Exit Sub
ErrHandler:
Debug.Print "Item index " & i & " is not a MailItem; skipping."
Resume SkipToNext
Notice I'm putting the assignment/validation as early as possible in the loop - that way you don't run useless instructions if you're not looking at a MailItem.
Another - better - way to go about it, would be to validate the type of olItems(i):
Dim olItem As Object
'...
For i = 1 To olItems.Count
Set olItem = olItems(i)
If Not TypeOf olItem Is Outlook.MailItem Then Goto SkipToNext
Set olMail = olItem ' essentially a type cast from Object to MailItem
...
SkipToNext:
Next
Alternatively, you can drop that GoTo jump and increase the nesting level instead:
For i = 1 To olItems.Count
Set olItem = olItems(i)
If TypeOf olItem Is Outlook.MailItem Then
Set olMail = olItem ' essentially a type cast from Object to MailItem
...
End If
Next
Note the indentation; feel free to use an indenter if you're not sure how to do this correctly & consistently. Proper indentation is critical for code readability, especially given nested looping & conditional structures (disclaimer: I own that website and the OSS project it's for).

Copy found emails 4 times

I have macro that searches for a subject and if found copy the email in another folder. My problem is that it copies the email 4 times instead of only once. If i have 10 emails in the original folder "Left Ones" then, after search and copy i will have 40 emails in the folder "TO BE REMOVED" . Any help is welcomed, thank you.
Sub Search_Inbox()
Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim subject_to_find As String
Dim myDestFolder As Outlook.Folder
subject_to_find = "something"
Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = OpenOutlookFolder("\\Mailbox - ME\Inbox\Left Ones")
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & subject_to_find & "%'"
Set filteredItems = objFolder.Items.Restrict(strFilter)
If filteredItems.Count = 0 Then
Debug.Print "No emails found"
Found = False
Else
Found = True
For Each itm In filteredItems
If itm.Class = olMail Then
Debug.Print itm.Subject
Debug.Print itm.ReceivedTime
End If
Set myDestFolder = Session.Folders("Mailbox - ME").Folders("TO BE REMOVED")
For i = filteredItems.Count To 1 Step -1
Dim myCopiedItem As Object
Set myCopiedItem = filteredItems(i).Copy
myCopiedItem.Move myDestFolder
Next i
Next itm
End If
'If the subject isn't found:
If Not Found Then
'NoResults.Show
Else
Debug.Print "Found " & filteredItems.Count & " items."
End If
Set myOlApp = Nothing
End Sub
After
Else
Found = True
add the line
Debug.Print filteredItems.Count
This is to check the number of items found. This way, you can definitely see if VBA actually finds 40 emails (for whatever reason), or if it just copies it 4 times later on.
Also try Changing
Next i
to
i = i + 1
Edit:
Cut the
Next itm
and move it to the end of this block:
For Each itm In filteredItems
If itm.Class = olMail Then
Debug.Print itm.Subject
Debug.Print itm.ReceivedTime
End If
Next itm 'move it here
For future searchers here is the working code to find all the emails with a given subject in a subfolder - Inbox\Left Ones - and copy them in another subfolder - Inbox\TO BE REMOVED - ( note that it will leave out the undelivered notification ) :
Sub Search_Inbox_Subfolder_Left_Ones()
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim subject_to_find As String
Dim myDestFolder As Outlook.Folder
Dim myCopiedItem As Object
subject_to_find = "something to find"
Set objFolder = OpenOutlookFolder("\\Mailbox - ME\Inbox\Left Ones")
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & subject_to_find & "%'"
Set filteredItems = objFolder.Items.Restrict(strFilter)
If filteredItems.Count = 0 Then
Debug.Print "No emails found"
Found = False
Else
Found = True
Set myDestFolder = Session.Folders("Mailbox - ME").Folders("TO BE REMOVED")
For i = filteredItems.Count To 1 Step -1
If filteredItems(i).Class = olMail Then
Set myCopiedItem = filteredItems(i).Copy
myCopiedItem.Move myDestFolder
End If
Next i
End If
'If the subject isn't found:
If Not Found Then
'NoResults.Show
Else
Debug.Print "Found " & filteredItems.Count & " items."
End If
Set myOlApp = Nothing
End Sub
Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant, _
varFolder As Variant, _
bolBeyondRoot As Boolean
On Error Resume Next
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
Do While Left(strFolderPath, 1) = "\"
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
Loop
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
Select Case bolBeyondRoot
Case False
Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
bolBeyondRoot = True
Case True
Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
End Select
If Err.Number <> 0 Then
Set OpenOutlookFolder = Nothing
Exit For
End If
Next
End If
On Error GoTo 0
End Function

Error creating Outlook Task Item in Sub-folder of Task folder

I've been using a routine that I discovered on Stack Overflow to automatically create a task item in Outlook in the default Tasks folder. I attempted to modify it to create the task in one of two sub-folders of Tasks named "New FTEs" and "New Consultants".
Running this code results in this message from the error handler.
Error Number: -2147221233
Error Source: AddOlkTask
Error Description: The attempted operation failed. An object could not be found.
The problem code is shown between 'start new code and 'end new code. I've tried many variants of this code, but I can't crack it (no pun intended).
Sub AddOlTask(sSubject, sBody, dtDueDate, dtReminderDate, name, program)
On Error GoTo Error_Handler
Dim noDue, pFolder, reminderSetFlag As String
reminderSetFlag = False
If program <> "Career Path Curriculum" Then
dtDue = dtDueDate
dtReminder = dtReminderDate
reminderSetFlag = True
End If
If program = "Active Consultant" Then
pFolder = "New Consultants"
Else
pFolder = "New FTEs"
End If
Const olTaskItem = 3
Dim olApp As Object
Dim OlTask As Object
Set olApp = CreateObject("Outlook.Application")
Set OlTask = olApp.CreateItem(olTaskItem)
With OlTask
.Subject = name & ": " & sSubject
.Status = 1 '0=not started, 1=in progress, 2=complete, 3=waiting,
'4=deferred
.Importance = 1 '0=low, 1=normal, 2=high
.dueDate = dtDue
.ReminderSet = reminderSetFlag
.ReminderTime = dtReminder
.Categories = "Mandatory SkillSoft Training" 'use any of the predefined Categorys or create your own
.body = sBody
.Display
.Save
End With
'start new code
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim tsk As Outlook.TaskItem
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderTasks)
Set olFolder = olFolder.Folders(pFolder) 'error raised on this line
'end new code
Error_Handler_Exit:
On Error Resume Next
Set OlTask = Nothing
Set olApp = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: AddOlkTask" & vbCrLf & "Error Description: " & _
Err.Description, vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
I had a similar problem and perhaps the cause of your problem is the same. I discovered the default Inbox was not in the store into which all my emails were loaded from my ISP. The default Inbox was in fact empty because it had never been used.
Run the macro below to discover what default folders you have and which store contains them.
Sub DsplUsernameOfDefaultStores()
Dim NS As Outlook.NameSpace
Dim DefaultFldr As MAPIFolder
Dim FldrTypeNo() As Variant
Dim FldrTypeName() As Variant
Dim InxFldr As Long
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
FldrTypeNo = VBA.Array(olFolderCalendar, olFolderConflicts, olFolderContacts, _
olFolderDeletedItems, olFolderDrafts, olFolderInbox, _
olFolderJournal, olFolderJunk, olFolderLocalFailures, _
olFolderManagedEmail, olFolderNotes, olFolderOutbox, _
olFolderSentMail, olFolderServerFailures, _
olFolderSuggestedContacts, olFolderSyncIssues, olFolderTasks, _
olPublicFoldersAllPublicFolders, olFolderRssFeeds)
FldrTypeName = VBA.Array("Calendar", "Conflicts", "Contacts", _
"DeletedItems", "Drafts", "Inbox", _
"Journal", "Junk", "LocalFailures", _
"ManagedEmail", "Notes", "Outbox", _
"SentMail", "ServerFailures", _
"SuggestedContacts", "SyncIssues", "Tasks", _
"AllPublicFolders", "RssFeeds")
Debug.Print "Stores containing default folders"
For InxFldr = 0 To UBound(FldrTypeNo)
Set DefaultFldr = Nothing
On Error Resume Next
Set DefaultFldr = NS.GetDefaultFolder(FldrTypeNo(InxFldr))
On Error GoTo 0
If DefaultFldr Is Nothing Then
Debug.Print "No default " & FldrTypeName(InxFldr)
Else
Debug.Print "Default " & FldrTypeName(InxFldr) & " in """ & DefaultFldr.Parent.Name & """"
End If
Next
End Sub
Second attempt at identifying the problem
I have added two sub-folders to my Tasks folders and then used the following macro to successfully display their names.
I have used Session instead of GetNamespace("MAPI"). These are supposed to be equivalent but I have once had Session work when GetNamespace("MAPI") did not. I don't remember the details and I did not investigate since I was happy to use Session.
You will need to amend my Set Fldr ... statement if your Tasks folder is not in the same location as mine. You can use Set Fldr = Session.GetDefaultFolder(olFolderTasks) if you prefer.
I have displayed the names with square brackets round them to highlight any stray spaces within the name.
Sub DsplTaskFolders()
Dim Fldr As Folder
Dim InxTskFldrCrnt
Set Fldr = Session.Folders("Outlook data file").Folders("Tasks")
For InxTskFldrCrnt = 1 To Fldr.Folders.Count
Debug.Print "[" & Fldr.Folders(InxTskFldrCrnt).Name & "]"
Next
End Sub
Thanks again Tony. You're code helped me understand the issue. I was not creating the custom folders in the correct location in Outlook. I created then under Inbox, when I should have created them under Tasks. The difference is not obvious. You basically have to right-click on the object Tasks - username#domain.com and select Create New Folder. If you right-click somewhere else, for instance, on the To-Do List, you'll create the folder under Inbox. It's working now.

Remove duplicate Outlook items from a folder

issue
Outlook 2016 corrupted while I was moving items from an online archive into a pst file.
The PST file has been recovered .... but many items (~7000) are duplicated 5 times
There are a range of item types, standard messages, meeting requests etc
what I tried
I looked at existing solutions and tools, including:
duplicate removal tools - none of which were free other than a trial option to remove 10 items at a time.
A variety of code solutions including:
Jacob Hilderbrand's effort which runs from Excel
Macro in Outlook to delete duplicate emails-
I decided to go the code route as it was relatively simple and to gain more control over how the duplicates were reported.
I will post my self solution below as it may help others.
I would like to see other potential approaches (perhaps powershell) to fixing this problem which may be better than mine.
The approach below:
Provides users with a prompt to select the folder to process
Checks duplicates on the base of Subject, Sender, CreationTime and Size
Moved (rather than delete) any duplicates into a sub-folder (removed items) of the folder being processed.
Create a CSV file - stored under the path in StrPath to create a external reference to Outlook of the emails that have been moved.
Updated: Checking for size surprisingly missed a number of dupes, even for otherwise identical mail items. I have changed the test to subject and body
Tested on Outlook 2016
Const strPath = "c:\temp\deleted msg.csv"
Sub DeleteDuplicateEmails()
Dim lngCnt As Long
Dim objMail As Object
Dim objFSO As Object
Dim objTF As Object
Dim objDic As Object
Dim objItem As Object
Dim olApp As Outlook.Application
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olFolder2 As Folder
Dim strCheck As String
Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.CreateTextFile(strPath)
objTF.WriteLine "Subject"
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
If olFolder Is Nothing Then Exit Sub
On Error Resume Next
Set olFolder2 = olFolder.Folders("removed items")
On Error GoTo 0
If olFolder2 Is Nothing Then Set olFolder2 = olFolder.Folders.Add("removed items")
For lngCnt = olFolder.Items.Count To 1 Step -1
Set objItem = olFolder.Items(lngCnt)
strCheck = objItem.Subject & "," & objItem.Body & ","
strCheck = Replace(strCheck, ", ", Chr(32))
If objDic.Exists(strCheck) Then
objItem.Move olFolder2
objTF.WriteLine Replace(objItem.Subject, ", ", Chr(32))
Else
objDic.Add strCheck, True
End If
Next
If objTF.Line > 2 Then
MsgBox "duplicate items were removed to ""removed items""", vbCritical, "See " & strPath & " for details"
Else
MsgBox "No duplicates found"
End If
End Sub
Here's a script that takes advantage of sorting emails to check for duplicates much more efficiently.
There's no need to maintain a giant dictionary of every email you've seen if you are processing emails in a deterministic order (e.g. received date). Once the date changes, you know you'll never see another email with the prior date, therefore, they won't be duplicates, so you can clear your dictionary on each date change.
This script also takes into account the fact that some items use an HTMLBody for the full message definition, and others don't have that property.
Sub DeleteDuplicateEmails()
Dim allMails As Outlook.Items
Dim objMail As Object, objDic As Object, objLastMail As Object
Dim olFolder As Folder, olDuplicatesFolder As Folder
Dim strCheck As String
Dim received As Date, lastReceived As Date
Set objDic = CreateObject("scripting.dictionary")
With Outlook.Application.GetNamespace("MAPI")
Set olFolder = .PickFolder
End With
If olFolder Is Nothing Then Exit Sub
On Error Resume Next
Set olDuplicatesFolder = olFolder.Folders("Duplicates")
On Error GoTo 0
If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = olFolder.Folders.Add("Duplicates")
Debug.Print "Sorting " & olFolder.Name & " by ReceivedTime..."
Set allMails = olFolder.Items
allMails.Sort "[ReceivedTime]", True
Dim totalCount As Long, index As Long
totalCount = allMails.count
Debug.Print totalCount & " Items to Process..."
lastReceived = "1/1/1987"
For index = totalCount - 1 To 1 Step -1
Set objMail = allMails(index)
received = objMail.ReceivedTime
If received < lastReceived Then
Debug.Print "Error: Expected emails to be in order of date recieved. Previous mail was " & lastReceived _
& " current is " & received
Exit Sub
ElseIf received = lastReceived Then
' Might be a duplicate track mail contents until this recieved time changes.
' Add the last mail to the dictionary if it hasn't been tracked yet
If Not objLastMail Is Nothing Then
Debug.Print "Found multiple emais recieved at " & lastReceived & ", checking for duplicates..."
objDic.Add GetMailKey(objLastMail), True
End If
' Now check the current mail item to see if it's a duplicate
strCheck = GetMailKey(objMail)
If objDic.Exists(strCheck) Then
Debug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
objMail.Move olDuplicatesFolder
DoEvents
Else
objDic.Add strCheck, True
End If
' No need to track the last mail, since we have it in the dictionary
Set objLastMail = Nothing
Else
' This can't be a duplicate, it has a different date, reset our dictionary
objDic.RemoveAll
lastReceived = received
' Keep track of this mail in case we end up needing to build a dictionary
Set objLastMail = objMail
End If
' Progress update
If index Mod 10 = 0 Then
Debug.Print index & " Remaining..."
End If
DoEvents
Next
Debug.Print "Finished moving Duplicate Emails"
End Sub
And the helper function referenced above for "uniquely identifying" an email. Adapt as needed, but I think if the subject and full body are the same, there's no point in checking anything else. Also works for calendar invites, etc.:
Function GetMailKey(ByRef objMail As Object) As String
On Error GoTo NoHTML
GetMailKey = objMail.Subject & objMail.HTMLBody
Exit Function
BodyKey:
On Error GoTo 0
GetMailKey = objMail.Subject & objMail.Body
Exit Function
NoHTML:
Err.Clear
Resume BodyKey
End Function
I've wrote a VBA script called "Outlook Duplicated Items Remover"
The source code is available on GitHub
It will find all duplicated items in a folder and its subfolders and move them to a dedicated folder
I simplified the duplicate search as in my case I imported multiple duplicates from PST files but the full mail body didn't match. I don't know why, as I am sure those mail are true duplicates.
My simplification is to match ONLY the receive TIME STAMP and the SUBJECT.
I added an error exception for an error I got some times on the function: Set olDuplicatesFolder = olFolder.Folders("Duplicates").
I did a different format for the debug.print messages.
Attribute VB_Name = "DelDupEmails_DATE_SUBJECT"
Sub DeleteDuplicateEmails_DATE_SUBJECT()
Dim allMails As Outlook.Items
Dim objMail As Object, objDic As Object, objLastMail As Object
Dim olFolder As Folder, olDuplicatesFolder As Folder
Dim strCheck As String
Dim received As Date, lastReceived As Date
Set objDic = CreateObject("scripting.dictionary")
With Outlook.Application.GetNamespace("MAPI")
Set olFolder = .PickFolder
End With
If olFolder Is Nothing Then Exit Sub
On Error Resume Next
Set olDuplicatesFolder = olFolder.Folders("Duplicates")
On Error GoTo 0
If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = olFolder.Folders.Add("Duplicates")
Debug.Print "Sorting " & olFolder.Name & " by ReceivedTime..."
Set allMails = olFolder.Items
allMails.Sort "[ReceivedTime]", True
Dim totalCount As Long, index As Long
totalCount = allMails.Count
Debug.Print totalCount & " Items to Process..."
'MsgBox totalCount & " Items to Process..."
lastReceived = "1/1/1987"
For index = totalCount - 1 To 1 Step -1
Set objMail = allMails(index)
On Error Resume Next
received = objMail.ReceivedTime
On Error GoTo 0
If received < lastReceived Then
Debug.Print "Error: Expected emails to be in order of date recieved. Previous mail was " & lastReceived _
& " current is " & received
Exit Sub
ElseIf received = lastReceived Then
' Might be a duplicate track mail contents until this recieved time changes.
' Add the last mail to the dictionary if it hasn't been tracked yet
If Not objLastMail Is Nothing Then
Debug.Print olFolder & " : Found multiple emails recieved at " & lastReceived & ", checking for duplicates..."
'MsgBox "Found multiple emails recieved at " & lastReceived & ", checking for duplicates..."
objDic.Add GetMailKey(objLastMail), True
End If
' Now check the current mail item to see if it's a duplicate
strCheck = GetMailKey(objMail)
If objDic.Exists(strCheck) Then
Debug.Print "#" & index & " - Duplicate: " & lastReceived & " " & objMail.Subject
'Debug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
'MsgBox "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
objMail.Move olDuplicatesFolder
DoEvents
Else
objDic.Add strCheck, True
End If
' No need to track the last mail, since we have it in the dictionary
Set objLastMail = Nothing
Else
' This can't be a duplicate, it has a different date, reset our dictionary
objDic.RemoveAll
lastReceived = received
' Keep track of this mail in case we end up needing to build a dictionary
Set objLastMail = objMail
End If
' Progress update
If index Mod 100 = 0 Then
Debug.Print index & " Remaining... from " & olFolder
'MsgBox index & " Remaining..."
End If
DoEvents
Next
Debug.Print "Finished moving Duplicate Emails"
MsgBox "Finished moving Duplicate Emails"
End Sub
Function GetMailKey(ByRef objMail As Object) As String
On Error GoTo NoHTML
'GetMailKey = objMail.Subject & objMail.HTMLBody
GetMailKey = objMail.Subject ' & objMail.HTMLBody
Exit Function
BodyKey:
On Error GoTo 0
'GetMailKey = objMail.Subject & objMail.Body
GetMailKey = objMail.Subject ' & objMail.Body
Exit Function
NoHTML:
Err.Clear
Resume BodyKey
End Function

For Each loop: How to adjust code to move files in one run rather than multiple

I am using the below code to archive emails that have been marked completed. It is supposed to check all emails in our shared folder for anything marked complete prior to today's date. It works, but I must run the code multiple times to archive all of the affected quoted. Does anyone have any ideas how to get this to work in one shot?
Public Const CEpath As String = "\\s-estimating\CentralEstimating\"
Option Explicit
Public Const sArchivePath As String = Miscellaneous.CEpath + "Archives\"
Public Sub ArchiveInbox()
Dim dtDateToMove As Date
Dim iMessageCount As Integer
Dim oDestination As MAPIFolder
Dim oFileName As String
Dim oNamespace As NameSpace
Dim oMailItem As MailItem
Dim oProgress As New ProgressDialogue
Dim oSource As MAPIFolder
Dim oStore As Store
Dim oOSPsource As MAPIFolder
'Dim oOSPDestination As MAPIFolder
On Error GoTo HandleError
' Obtain a NameSpace object reference.
Set oNamespace = Application.GetNamespace("MAPI")
Set oStore = oNamespace.Stores.item("Rings")
Set oSource = oStore.GetDefaultFolder(olFolderInbox)
' try to connect to the OSP Folder
On Error Resume Next
'Debug.Print oSource.Folders("OSP Quotes").Items.count
Set oOSPsource = oSource.Folders("OSP Quotes")
On Error GoTo HandleError
' Start Progess form
oProgress.Configure title:="Archive Old RFQs", _
status:="Please stand by while the operation is being processed…", _
Min:=0, _
Max:=CDbl(oSource.Items.count), _
optShowTimeElapsed:=True, _
optShowTimeRemaining:=True
oProgress.Show vbModeless
' Open Archive (or create and open)
dtDateToMove = PreviousBusinessDay(Date)
If Month(PreviousBusinessDay(Date)) < 7 Then
oFileName = "RFQs " & Year(dtDateToMove) & " - Jan-Jun"
Else
oFileName = "RFQs " & Year(dtDateToMove) & " - Jul-Dec"
End If
' Debug.Print dtDateToMove
' Debug.Print oFileName
oNamespace.AddStoreEx Store:=sArchivePath & oFileName & ".pst", _
Type:=olStoreUnicode
Set oDestination = oNamespace.Folders.GetLast
If Not oDestination.Name = oFileName Then oDestination.Name = oFileName
' Sort through all closed emails in Rings and move them to the archive folder
For Each oMailItem In oSource.Items
iMessageCount = iMessageCount + 1
If oProgress.cancelIsPressed Then Exit For
' Debug.Print " " & oMailItem.TaskCompletedDate
If oMailItem.FlagStatus = olFlagComplete Then
If oMailItem.IsConflict Then
Err.Raise Number:=95, _
Description:="Mail Item Conflict Detected"
End If
If oMailItem.TaskCompletedDate <= dtDateToMove Then
oMailItem.Move oDestination
' Debug.Print " Moved"
End If
End If
oProgress.SetValue iMessageCount
Next oMailItem
ExitRoutine:
oProgress.Hide
If oOSPsource Is Nothing Then
Debug.Print "OSP Quotes folder was not found."
Else
If oOSPsource.Items.count > 0 Then
MsgBox "There are items in OSP Quotes.", vbInformation + vbOKOnly
End If
End If
' close the store
oNamespace.RemoveStore oDestination
Set oProgress = Nothing
Set oDestination = Nothing
' Set oOSPDestination = Nothing
Set oOSPsource = Nothing
Set oSource = Nothing
Set oStore = Nothing
Set oNamespace = Nothing
Exit Sub
HandleError:
Debug.Print Err.Number
Debug.Print Err.Description
Select Case Err.Number
Case 95
MsgBox Prompt:=oMailItem.Subject & vbCrLf & vbCrLf & "An email with the above subject line is in conflict." & _
vbCrLf & "You will need to resolve the conflict and run Export to Excel again.", _
Buttons:=vbCritical + vbOKOnly, _
title:="Conflict Resolution Required"
oProgress.Hide
GoTo ExitRoutine
Case Else
If Not ErrorHandling.ErrorLog(Err.Number, Err.Description, "Archive The Inbox") Then
Err.Clear
Resume
End If
End Select
End Sub
Do not use "for each" loop if you are modifying the collection
Change the loop
For Each oMailItem In oSource.Items
to a down "for" loop:
dim oItems = oSource.Items
for I = oItems.Count to 1 step -1
set oMailItem = oItems.Item(I)