Endless Loop - VBA Script That Runs when MailItem is Added to Sent Folder, then Creates Copy

Question

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.

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.

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!

Edit: Forgot to add I have this code pasted in my Outlook's ThisOutlookSession in the vb developer tab (VbaProject.OTM file)

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-") > 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 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

score 0 · Answer 1 · answered May 09 '13 at 23:41

0

You can set you own special property on the new message using MailItem.UserProperties before you save it. You can then check if that property exists (MailItem.UserProperties.Find) when ItemAdd event fires and skip the item if the property is set.

answered May 09 '13 at 23:41

Dmitry Streblechenko

62,942
4
53
78

score 0 · Answer 2 · answered May 09 '13 at 23:54

Instead of ItemAdd try Application_ItemSend.

http://msdn.microsoft.com/en-us/library/office/ff865076(v=office.14).aspx

It is simpler than it looks. In the ThisOutlookSession module.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'  your code here
End Sub

You can test it with the example provided in the link.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 

    Dim prompt As String 

    prompt = "Are you sure you want to send " & Item.Subject & "?" 

    If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then 

        Cancel = True 

    End If 

End Sub

This looks like it would do the job, and will be definitely incorporating this method over item add in a future script I've been tasked with. Thank you for the help! — Banana, May 10 '13 at 20:14

Daniel Dušek · Accepted Answer · 2013-05-10T18:31:16.453

Add module level variable e.g. 'm_cancelAdd' and set its value to true before Item.Copy. At the very beginnig of the ItemAdd event handler check the value of m_cancelAdd and if it is true then reset it and exit the handler. HTH.

Private WithEvents Items As Outlook.Items
Private m_cancelAdd As Boolean

Private Sub Items_ItemAdd(ByVal Item As Object)

    If (m_cancelAdd) Then
        m_cancelAdd = False
        Exit Sub
    End If

    Dim myCopiedItem As Outlook.MailItem
    Dim FolderDest

    m_cancelAdd = True
    Set myCopiedItem = Item.Copy
    Debug.Print "Item copy created..."

    Set FolderDest = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)
    Item.Move FolderDest

End Sub

This works wonderfully, and didn't require very many edits to get working with my current code. As someone new to vb (and programming in general) the help is immensely appreciated! — Banana, May 10 '13 at 20:12

Endless Loop - VBA Script That Runs when MailItem is Added to Sent Folder, then Creates Copy

3 Answers3