title: Having Trouble Assigning an Outlook Category to a MailItem with VBA
body: <p>I have put together a vba script (that runs in ThisOutlookSession) that monitors MailItems added to my sent folder, and when it detects a project number in the subject, it copies that MailItem to a shared mailbox location automatically based on that project number.</p>
  
  <p>The scripts works well, however I would like to categorize all MailItems copied/moved by the script, so that users will have a visual indication to which messages were automatically moved by the script (since the end product will run invisible in the background). </p>
  
  <p>I'm missing something somewhere as its not assigning the category at the end of my script. Below is my full script (including my attempt to assign the mailitem to a category, which is under the " 'Assigns Category to Mailitem " comment). Any help, insight or direction will be immensely appreciated:</p>
  
  <hr>
  
  <pre><code>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-") &gt; 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-") &gt; 0 Then
  
                        FullProjectNum = EmailSubArr(i)
                        MsgBox "T-# Extracted"
                        ProjNumLen = Len(FullProjectNum)
  
                        MsgBox ("T-# is " &amp; ProjNumLen &amp; " Characters Long")
  
                        'Project Number Length Check and Formatting
  
                        If ProjNumLen &gt;= 11 Then
                          Exit Sub
                        End If
  
                        If ProjNumLen &lt;= 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-" &amp; ProjectNum)
              MsgBox ("Confirm Extraction (2 of 3) - Parent Folder Will Be " &amp; ParentFolderName)
              MsgBox ("Confirm Extraction (3 of 3) - Sub Folder Will Be " &amp; 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
  </code></pre>