Copier des e-mails vers un autre dossier à partir d'une boîte aux lettres partagée - Plusieurs utilisateurs

Question

J'ai 2 macros qui copient des e-mails avec un certain terme dans le sujet (1 pour la boîte de réception, 1 pour les éléments envoyés) dans une boîte aux lettres partagée. Cela fonctionne bien sur ma machine mais je dois mettre les macros sur les ordinateurs de tous les autres membres de mon équipe pour m'assurer que les copies arrivent quand quelqu'un n'est pas dedans.

Je comprends que ceci devrait (devrait) conduire à copie de chaque email pour chaque utilisateur qui a la macro ce qui est bien parce que je n'utilise que ce dossier pour lier à une feuille Excel qui tire l'info dans le corps des e-mails dans un classeur et un simple supprimer les doublons se débarrasser de les copies. Le problème est que je l'ai testé sur une autre machine avec la mienne et que les emails ne faisaient que copier, je parle environ 20 fois et je n'arrive pas à comprendre pourquoi cela pourrait se produire.

J'ai copié le code ci-dessous, si quelqu'un a des idées pourquoi cela pourrait se produire ou un travail potentiel, je serais très reconnaissant!

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

Je pensais publier mon correctif au cas où quelqu'un d'autre aurait le même problème. C'est assez simple en fait et surmonte le problème de la duplication pour chaque personne qui a le code actif sur la boîte aux lettres partagée. Le problème était assez simple (après avoir demandé à niton!) Où chaque copie déclenchait à nouveau l'événement et était donc dans une boucle sans fin (ce qui me semble un peu pénible étant donné que le dossier que j'ai enregistré était en dehors de la boîte de réception -le-by). La solution consistait à enregistrer l'élément de courrier en tant que fichier .msg et à demander à mon Excel WB de rechercher cet emplacement. La seule complication est que Excel ne peut pas lire dans les fichiers .msg afin d'obtenir les propriétés (telles que .Subject et .Body etc), vous devez le tromper en utilisant oOL.CreateItemFromTemplate(myPath & myMsg), oOL étant Dim oOL As Outlook.Application & Set oOL = CreateObject("Outlook.Application").

Le code ci-dessous est la version complète de mon code de perspectives au cas où cela aiderait quelqu'un dans le futur.

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

est exactement la même chose pour Private Sub olSentItems_ItemAdd(ByVal Item As Object) sauf que je changé le préfixe au nom du fichier à "Out - " & etc. Tous les autres bits de code dans la question ci-dessus sont restés les mêmes.