将电子邮件从共享邮箱复制到另一个文件夹 - 多个用户

我有2个宏将主题中的特定术语（1个用于收件箱，1个用于发送项目）的电子邮件从共享邮箱复制到该邮箱内的文件夹中。它在我的机器上工作正常，但我需要将宏放在我团队中其他人的计算机上，以确保在有人不在时发生复制。将电子邮件从共享邮箱复制到另一个文件夹 - 多个用户

我知道这会（应该）导致每个用户拥有这个宏的每个电子邮件的副本都很好，因为我只使用该文件夹链接到一个Excel表格，该表格将电子邮件正文中的信息拉入工作簿，并且简单移除重复项目将摆脱副本。

问题是我在另一台机器上对它进行了测试，还有我的电子邮件只是不停地复制，我正在谈论20次，我无法理解为什么这会发生。

我已经复制下面的代码，如果有人有任何想法，为什么它可能会发生或潜在的工作，我会很感激！

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

来源

2017-04-26 jamieee

一步一步地运行您的代码，并告诉我们不良行为发生在哪里，这样我们可以更快地帮助您。定义“**电子邮件只是复制**”。 –

我建议msg.copy添加到文件夹，触发ItemAdd代码。 – niton

对于迟到的道歉，我在发帖后整天被叫出办公室。谢谢你回到我身旁。大卫 - 代码的单次迭代会导致预期的结果，问题在于代码不断运行导致重复。 niton - 一个非常好的观点，我把它放在m_cancelAdd作品中，因为它会为单个用户造成无限数量的副本，但每个副本都会为每个用户重新开始。有什么建议么？ – jamieee

我想我会发布我的修复程序，以防其他人有同样的问题。这实际上非常简单，并且克服了在共享邮箱上激活代码的每个人的重复问题。

问题很简单（在niton提示后），每个副本再次触发事件，因此处于一个无止境的循环中（考虑到我保存的文件夹位于收件箱外部， -the-通过）。解决方案是将邮件项目保存为.msg文件，并让我的excel wb查找该位置。唯一的问题是，excel无法读取.msg文件，因此要获取属性（例如.Subject和.Body等），您必须使用oOL.CreateItemFromTemplate(myPath & myMsg)欺骗它，oOL是Dim oOL As Outlook.Application & Set oOL = CreateObject("Outlook.Application")。

下面的代码是我的Outlook代码的完整版本，以防将来帮助任何人。

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

代码是Private Sub olSentItems_ItemAdd(ByVal Item As Object)一模一样的，除了我在文件的名称改变了前缀"Out - " & etc。上述问题中的所有其他代码都保持不变。

来源

2017-05-03 07:48:42 jamieee

将电子邮件从共享邮箱复制到另一个文件夹 - 多个用户

回答

相关问题