我已经组合了一个 vba 脚本（在 ThisOutlookSession 中运行），它监视添加到我发送的文件夹中的 MailItems，当它检测到主题中的项目编号时，它会根据该项目编号自动将该 MailItem 复制到共享邮箱位置。
脚本运行良好，但是我想对脚本复制/移动的所有 MailItems 进行分类，以便用户可以直观地看到脚本自动移动了哪些邮件（因为最终产品将在后台不可见）。
我在某处遗漏了一些东西，因为它没有在我的脚本末尾分配类别。下面是我的完整脚本（包括我尝试将 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