Outlook Item Change duplication

Question

In Outlook, I have a VBA Script that reads new incoming emails and saves some information to an Excel file and also saves the text body and any attachments into a folder. Now, I want to change my script so that it saves any email with the category "Blue".

So I've modified some parts of here like so:

Public WithEvents objMails As Outlook.Items

Private Sub Application_Startup()
    Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub objMails_ItemChange(ByVal Item As Object)

    If Item.Class = olMail And Item.Categories = "Blue" Then
        Set objMail = Item
    Else
        Exit Sub
    End If
....

The rest of the code includes details about the saving, none of which was changed from my previously working script, but I've included it here for completeness.

...
'Specify the Excel file which you want to auto export the email list
'You can change it as per your case
strRootFolder = "N:\Outlook Excel VBA\"
strExcelFile = "EmailBookTest3.xlsx"

'Get Access to the Excel file
On Error Resume Next
Set objExcelApp = GetObject(, "Excel.Application")
If Error <> 0 Then
   Set objExcelApp = CreateObject("Excel.Application")
End If
Set objExcelWorkBook = objExcelApp.Workbooks.Open(strRootFolder & strExcelFile)
Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1")

'Get the next empty row in the Excel worksheet
nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1

'Specify the corresponding values in the different columns
strColumnB = objMail.Categories
strColumnC = objMail.SenderName
strColumnD = objMail.SenderEmailAddress
strColumnE = objMail.Subject
strColumnF = objMail.ReceivedTime
strColumnG = objMail.Attachments.Count

'Add the vaules into the columns
objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB
objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC
objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD
objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE
objExcelWorkSheet.Range("F" & nNextEmptyRow) = strColumnF

'Fit the columns from A to E
objExcelWorkSheet.Columns("A:F").AutoFit

'Save the changes and close the Excel file
objExcelWorkBook.Close SaveChanges:=True

'EmailBody
Dim FileSystem As Object
Dim FileSystemFile As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
FileSystem.CreateFolder (strRootFolder & "\" & nNextEmptyRow - 1)
Set FileSystemFile = FileSystem.CreateTextFile(strRootFolder & "\" & nNextEmptyRow - 1 & _
    "\Email_" & nNextEmptyRow - 1 & ".txt", True, True)
FileSystemFile.Write Trim(objMail.Body)
FileSystemFile.Close

'Attachments
Dim ItemAttachment As Attachment
For Each ItemAttachment In objMail.Attachments
    ItemAttachment.SaveAsFile strRootFolder & "\" & nNextEmptyRow - 1 & "\" & _
        ItemAttachment.FileName
Next ItemAttachment

End Sub

When I first change an email to "Blue", it seems like this script works perfectly: it populates a new row in the excel file with the information and creates a new folder that holds the text and attachments. However, after a few more seconds, it duplicates the records, so that each email is saved multiple times.

For example, if I do the following:

• Mark Email "Test 5" as Blue
• Immediately after mark Email "Test 4" as Blue

then my excel file looks like

+ -------- + -------- + ------------ + ------- +
| Email Id | Category | Sender       | Subject | ...
+ -------- + -------- + ------------ + ------- +
| 1        | Blue     | [email protected] | Test 5  | ...
| 2        | Blue     | [email protected] | Test 4  | ...
| 3        | Blue     | [email protected] | Test 4  | ...
| 4        | Blue     | [email protected] | Test 4  | ...
| 5        | Blue     | [email protected] | Test 5  | ...
+ -------- + -------- + ------------ + ------- +

But I only want it to show those changes once, like this:

+ -------- + -------- + ------------ + ------- +
| Email Id | Category | Sender       | Subject | ...
+ -------- + -------- + ------------ + ------- +
| 1        | Blue     | [email protected] | Test 5  | ...
| 2        | Blue     | [email protected] | Test 4  | ...
+ -------- + -------- + ------------ + ------- +

Any idea what might be happening? Thanks

Update:

Same thing happens with all my categories.

I'm using Outlook Version 14.0.7180.5002 (64-bit)

Answer 1

If ItemChange event triggers, it triggers, nothing you can do about it, unless you change the code behind ItemChange, which is unlikely.

But if you cannot change it, you can always control it. I tried to control it with LastModificationTime compared to current time but the trigger is sometimes instant so it did not work out well. Then I tried to control item's UserProperties which took me sometime to figure out, but eventually it worked. My code works with "Blue Category", so you can change it to "Blue" if it works for you.

Use the following:

Dim myProp As Outlook.UserProperty
Set myProp = Item.UserProperties.Find("MyProcess")

If Item.Categories <> "Blue Category" Then
    Debug.Print "Removing Blue Category and reseting Item Property"
    Set myProp = Item.UserProperties.Add("MyProcess", olText)
    myProp = True
    Exit Sub
End If

If TypeOf Item Is Outlook.MailItem And Item.Categories = "Blue Category" Then
    If myProp Is Nothing Then
        Debug.Print "Categorizing Item to Blue Category"
        Set myProp = Item.UserProperties.Add("MyProcess", olText)
        myProp = False
        Set objMail = Item
    ElseIf myProp = True Then
        Debug.Print "Re-categorizing Item to Blue Category"
        Set myProp = Item.UserProperties.Add("MyProcess", olText)
        myProp = False
        Set objMail = Item
    Else
        Debug.Print "Item has already been processed"
        Exit Sub
    End If
Else
    Debug.Print "Wrong category or action, exiting sub."
    Exit Sub
End If

instead of this:

If Item.Class = olMail And Item.Categories = "Blue" Then
    Set objMail = Item
Else
    Exit Sub
End If