Copy Emails to Another Folder from a Shared Mailbox - Multiple Users

Question

I have 2 macros that copies emails with a certain term in the subject (1 for inbox, 1 for sent items) from a shared mailbox into a folder within that mailbox. It works fine when on my machine but I need to put the macros on the computers of everyone else in my team to ensure the copies happen when someone isn't in.

I understand that this will (should) lead to a copy of each email for each user who has the macro which is fine because I'm only using this folder to link to an excel sheet which pulls the info in the body of the emails into a workbook and a simple remove duplicates will get rid of the copies.

The problem is I tested it on another machine along with it on mine and the emails just kept copying across, I'm talking around 20 times and I can't understand for the life of me why this might be happening.

I've copied the code in below, if anyone has any ideas why it might be happening or a potential work around I'd be most grateful!

Private WithEvents olInboxItems As Items
Private WithEvents olSentItems As Items
Private m_cancelAdd As Boolean


Private Sub Application_Startup()

  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace

  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  Set olInboxItems = objNS.Folders("Merchandise Support").Folders("Inbox").Items
  Set olSentItems = objNS.Folders("Merchandise Support").Folders("Sent Items").Items

End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

On Error GoTo ErrorHandler

If (m_cancelAdd) Then
m_cancelAdd = False
    Exit Sub
End If

Dim olApp As Outlook.Application
Dim ns As Outlook.NameSpace
Dim moveToFolder As Outlook.MAPIFolder
Dim Msg As Outlook.MailItem

    If TypeName(Item) = "MailItem" Then

        If Item.Subject Like "*MSR*" Then

            Set olApp = Outlook.Application
            Set ns = olApp.GetNamespace("MAPI")
            Set moveToFolder = ns.Folders("Merchandise Support").Folders("Support Requests")
            Set Msg = Item

            m_cancelAdd = True
            Msg.Copy
            Msg.Move moveToFolder

        End If

    End If

ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Private Sub olSentItems_ItemAdd(ByVal Item As Object)

On Error GoTo ErrorHandler

If (m_cancelAdd) Then
m_cancelAdd = False
    Exit Sub
End If

Dim olApp As Outlook.Application
Dim ns As Outlook.NameSpace
Dim moveToFolder As Outlook.MAPIFolder
Dim Msg As Outlook.MailItem

    If TypeName(Item) = "MailItem" Then

        If Item.Subject Like "*MSR*" Then

            Set olApp = Outlook.Application
            Set ns = olApp.GetNamespace("MAPI")
            Set moveToFolder = ns.Folders("Merchandise Support").Folders("Support Requests")
            Set Msg = Item

            m_cancelAdd = True
            Msg.Copy
            Msg.Move moveToFolder

        End If

    End If

ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Answer 1

I thought I'd post my fix in case anyone else has the same problem. It's quite simple actually and overcomes the issue of duplication for each person who has the code active on the shared mailbox.

The problem was quite simple (after prompting from niton!) whereby each copy triggered the event again so was in an unending loop (which seems a bit barmy to me considering the folder I saved to was outside the inbox but that's by-the-by). The solution was to save the mail item as a .msg file and have my excel wb look up to that location. The only complication was that excel can't read in .msg files so to get the properties (such as .Subject and .Body etc) you have to trick it using oOL.CreateItemFromTemplate(myPath & myMsg) , oOL being Dim oOL As Outlook.Application & Set oOL = CreateObject("Outlook.Application") .

The code below is the complete version of my outlook code in case it helps anybody in the future.

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

On Error GoTo ErrorHandler

Dim sPath As String
Dim sName As String
Dim rDate As Date

sPath = "C:\Example\"

    If TypeName(Item) = "MailItem" Then

        If Item.Subject Like "*MSR*" Then

            rDate = Item.ReceivedTime

            sName = "In - " & Mid(Item.Subject, InStr(1, Item.Subject, "MSR"), 9) & " - " & Format(rDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & Format(rDate, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & ".msg"

            Item.SaveAs sPath & sName, olMSG

        End If

    End If

ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Code is exactly the same for Private Sub olSentItems_ItemAdd(ByVal Item As Object) except I changed the prefix in the name of the file to "Out - " & etc . All the other bits of code in the question above remained the same.