使用 VBA 将 Outlook 类别分配给 MailItem 时遇到问题

Question

我已经组合了一个 vba 脚本（在 ThisOutlookSession 中运行），它监控添加到我发送的文件夹中的 MailItems，当它检测到主题中的项目编号时，它会根据该项目自动将该 MailItem 复制到共享邮箱位置号码。

脚本运行良好，但是我想对脚本复制/移动的所有 MailItem 进行分类，以便用户可以直观地看到脚本自动移动了哪些邮件（因为最终产品将在背景）。

我在某处遗漏了一些东西，因为它没有在我的脚本末尾分配类别。下面是我的完整脚本（包括我尝试将 mailitem 分配给一个类别，该类别位于“'Assigns Category to Mailitem”评论下）。任何帮助、见解或方向将不胜感激：

---

Private WithEvents Items As Outlook.Items

Private CancelLoop As Boolean
Private DupSubject As String

Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Set olApp = Outlook.Application


  Set InboxItems = GetNS(olApp).GetDefaultFolder(olFolderInbox).Items
  Set Items = GetNS(olApp).GetDefaultFolder(olFolderSentMail).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

    'Start Loop Check - Compares to last moved mailitem
    If item.Subject = DupSubject Then
        CancelLoop = True
    End If

    If (CancelLoop) Then
        MsgBox ("Ending Script (Loop Detected)")
        CancelLoop = False
        Exit Sub
    End If

  On Error Resume Next

  MsgBox "New item in the SENT Folder, Checking for T-#"

  Dim EmailSub As String
  Dim EmailSubArr As Variant
  Dim ProjectNum As String
  Dim FullProjectNum As String
  Dim ProjNumLen As Long
  Dim ParentFolderName As String
  Dim SubFolderName As String


    If TypeName(item) = "MailItem" Then
        'Checks Email Subject for Project Number Tag
        If InStr(item.Subject, "T-") > 0 Then

            MsgBox "T-# Detected"



            'Splits out Project Number into an Array for Extraction
            EmailSub = item.Subject
            EmailSubArr = Split(EmailSub, Chr(32))

              For i = LBound(EmailSubArr) To UBound(EmailSubArr)
                  If InStr(EmailSubArr(i), "T-") > 0 Then

                      FullProjectNum = EmailSubArr(i)
                      MsgBox "T-# Extracted"
                      ProjNumLen = Len(FullProjectNum)

                      MsgBox ("T-# is " & ProjNumLen & " Characters Long")

                      'Project Number Length Check and Formatting

                      If ProjNumLen >= 11 Then
                        Exit Sub
                      End If

                      If ProjNumLen <= 6 Then
                        Exit Sub
                      End If

                      If ProjNumLen = 10 Then
                      'Really Extended T-# Format 1(ie T-38322X12)
                      ProjectNum = Right(FullProjectNum, 8)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 8)
                      End If

                      If ProjNumLen = 9 Then
                      'Extended T-# Format 1(ie T-38322X1)
                      ProjectNum = Right(FullProjectNum, 7)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 7)
                      End If

                      If ProjNumLen = 8 Then
                      'Uncommon T-# Format (ie T-38322A)
                      ProjectNum = Right(FullProjectNum, 6)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 6)
                      End If

                      If ProjNumLen = 7 Then
                      'Standard T-# Format (ie T-38322)
                      ProjectNum = Right(FullProjectNum, 5)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 5)
                      End If

                      Exit For

                  End If
              Next i

            MsgBox ("Confirm Extraction (1 of 3) - Project Number is T-" & ProjectNum)
            MsgBox ("Confirm Extraction (2 of 3) - Parent Folder Will Be " & ParentFolderName)
            MsgBox ("Confirm Extraction (3 of 3) - Sub Folder Will Be " & SubFolderName)
            MsgBox ("Will Now Perform Folder Checks")

            'Perform Folder Checks, Creates Folders When Needed

            Dim fldrparent As Outlook.MAPIFolder
            Dim fldrsub As Outlook.MAPIFolder

            Set fldrparent = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName)
            Set fldrsub = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)

            If fldrparent Is Nothing Then
                MsgBox "Parent Folder Does Not Exist, Creating Folder"
                Set fldrparent = Outlook.Session.Folders("Projects").Folders("Project Root").Folders.Add(ParentFolderName)
            Else
                MsgBox "Parent Folder Already Exists, Do Nothing"
            End If

            If fldrsub Is Nothing Then
                MsgBox "Sub Folder Does Not Exist, Creating Folder"
                Set fldrsub = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders.Add(SubFolderName)
            Else
                MsgBox "Sub Folder Already Exists, Do Nothing"
            End If

            'Moves Copy of Email to Folder

            MsgBox "Copying Sent Email to Project Folder"

            Dim myCopiedItem As Outlook.MailItem
            Dim FolderDest As Outlook.MAPIFolder

            Set myCopiedItem = item.Copy
            Set FolderDest = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)

            item.Move FolderDest
            MsgBox "Copy Complete"

            'Assigns Category to Mailitem
            item.Categories = "Copied2Projects"
            item.save


            'Duplicate Email/Loop Check
            DupSubject = EmailSub

            Set objExplorer = Nothing

        Else
        MsgBox "Did not detect T-##### project number"
        End If

    End If

End Sub

Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
  Set GetNS = app.GetNamespace("MAPI")
End Function

Answer 1

你的问题在这里：

        Dim myCopiedItem As Outlook.MailItem
        item.Move FolderDest
        MsgBox "Copy Complete"

        'Assigns Category to Mailitem
        item.Categories = "Copied2Projects"
        item.save

当你移动一个项目时，Outlook 会做一些奇怪的事情，如果你不做任何事情来跟踪它，它就会有效地创建一个你不再可以访问的新项目。有几种方法可以解决此问题。

您可以将代码保存移到.Move 命令之前，完全避免这个问题。

否则，您可以尝试类似的方法

Set myCopiedItem = item.Move(FolderDest)
myCopiedItem.Categories = "Copied2Projects"
myCopiedItem.save 

这也应该有效。

这让我很长时间以来都因为一个相关的问题而疯狂...