Run-time error 13 randomly while iterating emails in a public folder - vba

I receive a random run-time error 13 (type mismatch). This routine works most of the time. The folder passed as an argument is legitimate at the time of the failure.
From what I can see in the debugger, objitem is missing some of the fields during runtime. After it break-points in the debugger, I can immediately single-step (re-executing the offending line) and there is no error.
I attempted using on error goto to sleep then retry various lines, and the error persists until it stops in the debugger.
I also attempted changing between the For ii and For Each forms of the loop commands.
I also temporarily disabled by anti-virus.
I iterate over a large number of public folders. My Outlook client is 2003 running under XP, and I am attached to Exchange Server version 7654.
Sub SearchFolders(objFolder As Outlook.MAPIFolder)
Dim objFolders As Outlook.Folders
Dim subFolder As Outlook.MAPIFolder
Dim objitem As MailItem
Dim ii As Integer
' Recurse through all subfolders
Set objFolders = objFolder.Folders
For Each subFolder In objFolders
Call SearchFolders(subFolder)
Next subFolder
' Search the emails
For ii = 1 To objFolder.Items.Count
If objFolder.Items(ii).Class = olMail Then
If TypeName(objFolder.Items(ii)) <> "MailItem" Then
MsgBox ("Type mismatch: object s/b MailItem and is " & TypeName(objFolder.Items(ii)))
GoTo NextdblLoop
End If
Set objitem = objFolder.Items(ii)
CheckEmailForErrorReports (objFolder.Items(ii))
End If
NextdblLoop:
Next ii
End Sub
Code below is modified per #dmitry suggestions and now works.
Sub SearchFolders(objFolder As Outlook.MAPIFolder)
Dim objFolders As Outlook.Folders
Dim subFolder As Outlook.MAPIFolder
Dim Objitem As Outlook.MailItem
Dim ii As Integer
Dim ThisItem As Object
Dim Items As Outlook.Items
' Recurse through all subfolders
Set objFolders = objFolder.Folders
For Each subFolder In objFolders
Call SearchFolders(subFolder)
Next subFolder
' Search the emails
Set Items = objFolder.Items
For ii = 1 To Items.Count
Set ThisItem = Items.item(ii)
If ThisItem.Class = olMail Then
If VarType(ThisItem) = 9 Then GoTo NextdblLoop
Set Objitem = ThisItem
CheckEmailForErrorReports (objFolder.Items(ii))
Set Objitem = Nothing
End If
Set ThisItem = Nothing
NextdblLoop:
Next ii
Set Items = Nothing
End Sub

Firstly, do not use multiple dot notation; cache the Items collection before entering the loop.
Secondly, release the variables as soon as you are done with them
dim item As Object
dim Items as Outlook.Items
set Items = objFolder.Items
For ii = 1 To Items.Count
set item = Items.Item(ii)
If item.Class = olMail Then
If TypeName(item) <> "MailItem" Then
'THIS CAN NEVER HAPPEN. The check above is sufficient
MsgBox ("Type mismatch: object s/b MailItem and is " & TypeName(item))
GoTo NextdblLoop
End If
Set objitem = item
CheckEmailForErrorReports (objitem)
Set objitem = Nothing
End If
Set item = Nothing
NextdblLoop:
Next ii
End Sub

Related

Set mails read if they were read in another folder

I'm trying to make an outlook macro, which will 'update' the mails. I have an Inbox folder and an another one. (2 mail accunts)
There is a rule, which is copying the mail from another folder to my inbox.
My goal is to set the mail as read in another folder, if it was read in the Inbox folder.
Sub precitane()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim mydeffolder As Outlook.Folder
Dim items As Object
Dim defitems As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myDestFolder = myNameSpace.Folders("") 'mymail
Set mydeffolder = myNameSpace.GetDefaultFolder(olFolderInbox)
For Each items In myDestFolder.items
For Each defitems In mydeffolder.items
If TypeOf items Is Outlook.MailItem & TypeOf defitems Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = items
Dim defMail As Outlook.MailItem: Set defMail = defitems
If oMail.SenderEmailAddress = "" & defMail.SenderEmailAddress = "" & defMail.Body = oMail.Body & defMail.UnRead = False Then
oMail.UnRead = True
oMail.Save
End If
End If
Next
Next
On Error GoTo 0
End Sub
"" contains my mail...
It looks like you tried with code from other than VBA.
I broke the If statement into separate parts as it is easier to follow and to debug.
Option Explicit
Sub precitane()
Dim myDestFolder As Folder
Dim mydeffolder As Folder
Dim item As Object
Dim defItem As Object
Set myDestFolder = Session.Folders("mailAddress2").Folders("Inbox").Folders("Test")
Set mydeffolder = Session.GetDefaultFolder(olFolderInbox).Folders("Test3")
For Each item In myDestFolder.items
If TypeOf item Is MailItem Then
For Each defItem In mydeffolder.items
If TypeOf defItem Is MailItem Then
If item.senderEmailAddress = defItem.senderEmailAddress Then
If item.Body = defItem.Body Then
If item.UnRead = False Then
defItem.UnRead = False
'If necessary
'item.Save
Exit For
End If
End If
End If
End If
Set defItem = Nothing
Next
End If
Set item = Nothing
Next
Debug.Print "Done."
End Sub

Iterating through multiple Selection / Folder items

I took at a look at MailItem and didn't see anything that would indicate that I could shift select items.
I have code that functions however, the Set objItem = GetCurrentItem() line only takes one mail.
I'm looking to either ForEach through a folder, or ForEach through a selection.
I tried something like
Sub ListMailsInFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Foldername").Folders("Subfoldername")
For Each Item In objFolder.Items
I don't have any idea what I'm doing.
Here is the code I'm trying to execute on multiple emails:
Sub HelpdeskNewTicket()
Dim helpdeskaddress As String
Dim objMail As Outlook.MailItem
Dim strbody As String
Dim oldmsg As String
Dim senderaddress As String
Dim addresstype As Integer
' Set this variable as your helpdesk e-mail address
helpdeskaddress = "danielbelamiinc#gmail.com"
Set objItem = GetCurrentItem()
Set objMail = objItem.Forward
' Sender E=mail Address
senderaddress = objItem.SenderEmailAddress
strbody = objItem.Body
objMail.To = helpdeskaddress
objMail.Subject = objItem.Subject
objMail.Body = strbody
'Automatically Send the ticket
objMail.Send
Set objItem = Nothing
Set objMail = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = _
objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = _
objApp.ActiveInspector.CurrentItem
Case Else
End Select
End Function
To loop through selection items use For...Next Statement Loop [MSDN]
Syntax
For counter = initial_value To end_value [Step step-counter]
Example on Selection Items
Option Explicit
Public Sub Example()
Dim Item As Outlook.mailitem
Dim i As Long
For i = ActiveExplorer.Selection.Count To 1 Step -1
Set Item = ActiveExplorer.Selection.Item(i)
Debug.Print Item.Subject
' Call Sub
Next
End Sub
Example on Folder Items
Option Explicit
Public Sub Example()
Dim Inbox As Outlook.folder
Set Inbox = Application.Session.GetDefaultFolder( _
olFolderInbox _
)
Dim Items As Outlook.Items
Set Items = Inbox.Items
Dim i As Long
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i) 'Print on Immediate Window
Next
End Sub
DoEvents MSDN & Debug.Print SO Link
Description
loop executes a given number of times, as determined by a loop counter. To use the For...Next loop, you must assign a numeric value to a counter variable. This counter is either incremented or decremented automatically with each iteration of the loop. In For statement, you specify the value that is to be assigned to the counter initially and the maximum value the counter will reach for the block of code to be executed. The Next statement marks the end of the block of code that is to execute repeatedly, and also serves as a kind of flag that indicates the counter variable is to be modified.
CurrentFolder Property
Returns or sets a MAPIFolder object that represents the current folder displayed in the explorer. Use this property to change the folder the user is viewing.

Delete email from inbox and also delete it from deleted-items folder via rule->script

I created a rule, that starts a VBA-script depending on the subject of a received email (Rule: Subject "MY_SUBJECT" -> start script).
The VBA script is then doing some stuff and then it should finally delete the original email.
This part is easy:
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' doSomething:
' delete email from inbox
Item.Delete
End Sub
Now the email will sit in the deleted-items-folder. But what I need to achieve is, to also delete this mail from the deleted-items folder. Since I know the subject of this mail (because this triggered my rule in the first place), I tried the following approach:
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' doSomething:
' delete email from inbox
Item.Delete
End Sub
' delete email from deleted items-folder
Dim deletedFolder As Outlook.Folder
Set deletedFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems)
Dim i As Long
For i = myFolder.Items.Count To 1 Step -1
If (deletedFolder.Items(i).Subject) = "MY_SUBJECT" Then
deletedFolder.Items(i).Delete
Exit For
End If
Next if
End Sub
Well, this basically works: The mail with this subject will be found in the deleted-items-folder and it will be deleted, yes.
But sadly it does not work as expected:
This permanent deletion only works once I start the script a second time.
So the email which is triggering my script will never be deleted permanently in this script's actual run, but only in the next run (once the next email with the trigger-subject for my rule is received - but then this very next email won't be deleted, again).
Do you have any idea what I am doing wrong here? It somehow looks like I need to refresh my deleted-items folder somehow. Or do I have to comit my first Item.Delete somehow explicitly?
The problem was not recreated, but try stepping through this then run normally if it appears to do what you want.
Sub doWorkAndDeleteMail(Item As mailitem)
Dim currFolder As Folder
Dim DeletedFolder As Folder
Dim i As Long
Dim mySubject As String
Set currFolder = ActiveExplorer.CurrentFolder
mySubject = Item.Subject
Debug.Print mySubject
Set DeletedFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems)
Set ActiveExplorer.CurrentFolder = DeletedFolder
Debug.Print "DeletedFolder.count before delete: " & DeletedFolder.Items.count
' delete email from deleted items-folder
Item.Delete
Debug.Print "DeletedFolder.count after delete: " & DeletedFolder.Items.count
' If necessary
'DoEvents
For i = DeletedFolder.Items.count To 1 Step -1
Debug.Print DeletedFolder.Items(i).Subject
If (DeletedFolder.Items(i).Subject) = mySubject Then
Debug.Print DeletedFolder.Items(i).Subject & " *** found ***"
DeletedFolder.Items(i).Delete
Exit For
End If
Next
Set ActiveExplorer.CurrentFolder = currFolder
End Sub
Tim Williams suggested another existing thread. I had a look at that already before and decided that appoach would be exactly the same representation of my bug. I did try it out, though (to show my motiviation :) ), but the behaviour is - as expected - exactly the same: Again the final deletion only works once the next time the script is triggered via rule:
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' First set a property to find it again later
Item.UserProperties.Add "Deleted", olText
Item.Save
Item.Delete
'Now go through the deleted folder, search for the property and delete item
Dim objDeletedFolder As Outlook.Folder
Dim objItem As Object
Dim objProperty As Variant
Set objDeletedFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems)
For Each objItem In objDeletedFolder.Items
Set objProperty = objItem.UserProperties.Find("Deleted")
If TypeName(objProperty) <> "Nothing" Then
objItem.Delete
End If
Next
End Sub
I would be really glad to get some help here. I also wanted to comment on that other thread, but my reputation is not enough, yet.
Try something like this, code goes under ThisOutlookSession
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Set Items = DeletedFolder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Filter As String
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Filter = "[Subject] = 'MY_SUBJECT'"
Set Items = DeletedFolder.Items.Restrict(Filter)
If TypeOf Item Is Outlook.MailItem Then
For i = Items.Count To 1 Step -1
DoEvents
Items.Remove i
Next
End If
End Sub
Edit
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' First set a property to find it again later
Item.UserProperties.Add "Deleted", olText
Item.Save
Item.Delete
'Now go through the deleted folder, search for the property and delete item
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Filter As String
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Filter = "[Subject] = 'MY_SUBJECT'"
Set Items = DeletedFolder.Items.Restrict(Filter)
If TypeOf Item Is Outlook.MailItem Then
For i = Items.Count To 1 Step -1
DoEvents
Items.Remove i
Next
End If
End Sub
the Mailbox folder that you get can be used as a collection, meaning that you can remove the item directly, you will need the collection to be sent to the function but that should be managable :)
Sub doWorkAndDeleteMail(Mailbox As Outlook.Folder, Item As Outlook.MailItem)
' doSomething:
' delete email from inbox
For Ite = 1 To Mailbox.Items.Count
If Mailbox.Items(Ite).EntryID = Item.EntryID Then
Mailbox.Items.Remove Ite
Exit For
End If
Next
End Sub
Remember that IF you want to Delete more than 1 Item per call of "For Ite = 1 To Mailbox.Items.Count", you will need to subtract 1 from the check of the item within the For segment since when you remove a mail from it, it will reduce the rest of the mails index number by 1.
Hope you can still use this :)
Regards Sir Rolin

Mark as Read loop errors on some mail items inconsistently

I receive 4000+ emails over a weekend and all throughout the week that are filtered into folders via rules. I created a macro to mark all these folders as read. However, on some mail items it errors with runtime error 91 object variable or with block variable not set.
If I skip the errors with On Error Resume Next it loops through everything but just doesn't set a bunch of the mail items as read. I can then rerurn the macro to get most of the remaining ones. If I run the macro 3-4 times it will eventually get them all.
How can I improve this macro to consistently mark ALL the items as read?
Public Function GetInboxFolderID(FolderName As String) As String
Dim nsp As Outlook.Folder
Dim mpfSubFolder As Outlook.Folder
Dim mpfSubFolder2 As Outlook.Folder
Dim flds As Outlook.Folders
Dim flds2 As Outlook.Folders
Set nsp = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set flds = nsp.Folders
Set mpfSubFolder = flds.GetFirst
Do While Not mpfSubFolder Is Nothing
If mpfSubFolder.Name = FolderName Then
GetInboxFolderID = mpfSubFolder.EntryID
Exit Function
End If
Set flds2 = mpfSubFolder.Folders
Set mpfSubFolder2 = flds2.GetFirst
Do While Not mpfSubFolder2 Is Nothing
If mpfSubFolder2.Name = FolderName Then
GetInboxFolderID = mpfSubFolder2.EntryID
Exit Function
End If
Set mpfSubFolder2 = flds2.GetNext
Loop
Set mpfSubFolder = flds.GetNext
Loop
End Function
Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim oFiltered As Outlook.Items
Set oFiltered = oParent.Items.Restrict("[unread] = true")
On Error Resume Next
For Each oMail In oFiltered
oMail.UnRead = False
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
End Sub
Public Sub markNocAsRead()
Dim SubFolder As MAPIFolder
Set SubFolder = Session.GetDefaultFolder(olFolderCalendar).Parent.Folders("NOC Alerts")
'Application.Session.GetFolderFromID (GetInboxFolderID("NOC Alerts"))
Call processFolder(SubFolder)
End Sub
I was able to get this working consistently by taking the advice of Ryan Wildry in a comment above.
I replaced my loop:
Set oFiltered = oParent.Items.Restrict("[unread] = true")
On Error Resume Next
For Each oMail In oFiltered
oMail.UnRead = False
Next
with a loop that iterates from the end to beginning:
Set oFiltered = oParent.Items.Restrict("[unread] = true")
For I = oFiltered.Count To 1 Step -1
Set oMail = oFiltered(I)
oMail.UnRead = False
Next

How to move messages from a specific account?

I have multiple accounts attached to Outlook 2010.
I want to move messages from a specific account, older than X days, to a .pst file for local storage.
I found scripts to move messages from the default inbox, but nothing on specifying an account.
I know you can specify an account when sending email using
Set OutMail.SendUsingAccount = Outlook.Application.Session.Accounts.Item(2)
but I can't find anything for looking into another account.
I've found the stores references for the folders (\Inbox and \Sent) and I know how to specify the days old. I have a script that works, but only in my primary account.
After some more searching and testing I came up with the following solution. This was actually from a 2009 post on stackoverflow here: Original VBA
It uses a public function to build the folder locations and a Subroutine to look for received dates older than 60 days and move those files to the specified locations.
The public function is:
Public Function GetFolder(strFolderPath As String) As MAPIFolder
Dim objNS As NameSpace
Dim colFolders As folders
Dim objFolder As MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error GoTo TrapError
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objNS = GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objNS.folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
On Error GoTo TrapError
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Exit_Proc:
Exit Function
TrapError:
MsgBox Err.Number & " " & Err.Description
End Function
The subroutine that does the actual work is below.
I added the Pass as Integer to allow the routine to work through two different source and destination folders. If I change the Sub name to Application_Startup it will run whenever outlook is started.
PST Folder Name\Archive-Inbox - PST folder name in Outlook with sub-folder
Email Account Name\Inbox - Account name in Outlook with sub-folder
Sub MoveOldEmail()
Dim oItem As MailItem
Dim objMoveFolder As MAPIFolder
Dim objInboxFolder As MAPIFolder
Dim i As Integer
Dim Pass As Integer
For Pass = 1 To 2
If Pass = 1 Then
Set objMoveFolder = GetFolder("PST Folder Name\Archive-Inbox")
Set objInboxFolder = GetFolder("Email Account Name\Inbox")
ElseIf Pass = 2 Then
Set objMoveFolder = GetFolder("PST Folder Name\Archive-Sent Items")
Set objInboxFolder = GetFolder("Email Account Name\Sent Items")
End If
For i = objInboxFolder.Items.Count - 1 To 0 Step -1
With objInboxFolder.Items(i)
''Error 438 is returned when .receivedtime is not supported
On Error Resume Next
If .ReceivedTime < DateAdd("d", -60, Now) Then
If Err.Number = 0 Then
.Move objMoveFolder
Else
Err.Clear
End If
End If
End With
Next
Next Pass
Set objMoveFolder = Nothing
Set objInboxFolder = Nothing
End Sub
Hope this helps someone else.