使用 VBA 根据票证 ID 创建 Outlook email 路由规则

Question

I tried to create email routing rule with below scenario.

• Incoming email will be located at Inbox/Active folder. Subject of the email will contain the ticket ID and content
• Once new email coming to Active subfolder, Outlook will get the email subject and create the subfolder with format "ticket ID - content" eg: "123123 - issue with outlook"
• Then a rule will be created to route this incoming email with ticket ID to the subfolder that I just created

Below is my code but it did not work. Only subfolder is created as expected. Please help me to review if any idea. Thanks

Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
  Dim olapp As Outlook.Application
  Dim olnamespace As Outlook.NameSpace
  
  Set olapp = Outlook.Application
  Set olnamespace = olapp.GetNamespace("MAPI")
  Set inboxItems = olnamespace.GetDefaultFolder(olFolderInbox).Folders("Filter").Items
End Sub

Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler

Dim olapp As Outlook.Application
Dim olnamespace As Outlook.NameSpace
Dim olActivefolder As Folder
Dim ticketnumber As String
Dim rightsubject As String
Dim leftsubject As String
Dim extsubject As String

 Dim colRules As Outlook.Rules 
 Dim oRule As Outlook.Rule 
 Dim colRuleActions As Outlook.RuleActions 
 Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction 
 Dim oFromCondition As Outlook.ToOrFromRuleCondition 
 Dim oExceptSubject As Outlook.TextRuleCondition 
 Dim oInbox As Outlook.Folder 
 Dim oMoveTarget As Outlook.Folder 
  
Set olapp = Outlook.Application
Set olnamespace = olapp.GetNamespace("MAPI")
Set olActivefolder = olnamespace.GetDefaultFolder(olFolderInbox).Folders("Active")

If TypeName(Item) = "MailItem" Then
   Debug.Print "triggered"
   ticketnumber = Item.Subject
   rightsubject = Right(ticketnumber, 16)
   leftsubject = Left(ticketnumber, 60)
   olActivefolder.Folders.Add (rightsubject & " - " & leftsubject)
End If

 Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox).Folders("Active")
 Set oMoveTarget = oInbox.Folders(rightsubject & " - " & leftsubject) 

 Set colRules = Application.Session.DefaultStore.GetRules()  
 Set oRule = colRules.Create(rightsubject, olRuleReceive) 

 Set oFromCondition = oRule.Conditions.Subject
 With oFromCondition 
 .Enabled = True 
 .Text = rightsubject
End With 

 Set oMoveRuleAction = oRule.Actions.MoveToFolder 
 With oMoveRuleAction 
 .Enabled = True 
 .Folder = oMoveTarget 
 End With 

colRules.Save 

ExitNewItem:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ExitNewItem
End Sub

Answer 1

The subject condition should look like this:

'Dim oFromCondition As Outlook.ToOrFromRuleCondition
'Set oFromCondition = oRule.Conditions.subject
'With oFromCondition
'    .Enabled = True
'    .Text = rightSubject
'End With

Dim oSubjectCondition As TextRuleCondition
Set oSubjectCondition = oRule.Conditions.subject
With oSubjectCondition
    .Enabled = True
    .Text = Array(rightSubject)
End With

Answer 2

There is likely no need for rules.

Private Sub inboxItems_ItemAdd_Test()
    inboxItems_ItemAdd ActiveInspector.CurrentItem
End Sub

Private Sub inboxItems_ItemAdd(ByVal Item As Object)

' Folder created for first mail
' No folder created for subsequent mail

Dim oInbox As folder
Dim oActivefolder As folder
Dim oMoveTarget As folder
Dim oFolder As folder

Dim ticketNumber As String

Set oInbox = Session.GetDefaultFolder(olFolderInbox)
Set oActivefolder = oInbox.Folders("Active")

If TypeName(Item) = "MailItem" Then

    Debug.Print "triggered"
    
    ' For testing
    ticketNumber = "123123"
    
    For Each oFolder In oActivefolder.Folders
        If oFolder.Name = ticketNumber Then
            Set oMoveTarget = oActivefolder.Folders(ticketNumber)
            Debug.Print " Folder exists: " & oMoveTarget.Name
            Exit For
        End If
    Next
    
    If oMoveTarget Is Nothing Then
        Set oMoveTarget = oActivefolder.Folders.Add(ticketNumber)
        Debug.Print " Folder added: " & oMoveTarget.Name
    End If
        
    Item.Move oMoveTarget

End If

Debug.Print "Done."

End Sub