title: Endless Loop - VBA Script That Runs when MailItem is Added to Sent Folder, then Creates Copy
body: <p>I recently completed an outlook vba script that will scan the subject line of each mailitem added to the sent folder, looking for a project number in the subject. When detected, the script extracts the project number, creates a copy of the mailitem and then moves that copy to shared mailbox folders based on the project number (performing folder checks first). I currently have it setup to create a copy of the mail item first, then move that copy to the new folder destination. This is so the original sent mailitem is left alone in the Sent Folder and not removed.</p>
  
  <p>The problem I've come across is when the script creates a copy of the mail item within the sent folder, it triggers a new instance of the script (since it runs when a new item is added to the sent folder) and will repeat this process indefinitely, creating and moving copies until Outlook is forced closed. Adding a loop count check doesn't seem to help because the script starts from scratch each time an item is added.</p>
  
  <p>Below is the full code, is there a better way to approach this than I'm currently doing? Any insight or direction will be greatly appreciated!</p>
  
  <p>Edit: Forgot to add I have this code pasted in my Outlook's ThisOutlookSession in the vb developer tab (VbaProject.OTM file)</p>
  
  <hr>
  
  <pre><code>Private WithEvents Items As Outlook.Items
  
  Private Sub Application_Startup()
    Dim olApp As Outlook.Application
  
    Set olApp = Outlook.Application
    Set Items = GetNS(olApp).GetDefaultFolder(olFolderSentMail).Items
  End Sub
  
  Private Sub Items_ItemAdd(ByVal item As Object)
  
    On Error Resume Next
  
    MsgBox "Mail Added to 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 FolderDest As Outlook.MAPIFolder
              Dim myItem As Outlook.MailItem
              Dim myCopiedItem As Outlook.MailItem
  
  
              Set FolderDest = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)
              'Set myCopiedItem = item.Copy
  
              item.Move FolderDest
  
          Else
          MsgBox "Did not detect T-##### project number"
          End If
  
      End If
  
  ProgramExit:
    Exit Sub
  
  End Sub
  
  Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
    Set GetNS = app.GetNamespace("MAPI")
  End Function
  </code></pre>