將電子郵件從共享郵箱複製到另一個文件夾 - 多個用戶

我有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

將電子郵件從共享郵箱複製到另一個文件夾 - 多個用戶

回答

相關問題