Question

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

Answer 1

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

问题很简单（在从niton提示之后！），每个副本再次触发了事件，因此处于无休止的循环中（考虑到我保存到的文件夹位于收件箱之外，这对我来说似乎有些不好看，但是＃39 ; s by-by-by）。解决方案是将邮件项目保存为.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。上述问题中的所有其他代码都保持不变。

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

1 个答案: