outlook - Endless Loop - VBA Script That Runs when MailItem is Added to Sent Folder, then Creates Copy -
i completed outlook vba script scan subject line of each mailitem added sent folder, looking project number in subject. when detected, script extracts project number, creates copy of mailitem , moves copy shared mailbox folders based on project number (performing folder checks first). have setup create copy of mail item first, move copy new folder destination. original sent mailitem left alone in sent folder , not removed.
the problem i've come across when script creates copy of mail item within sent folder, triggers new instance of script (since runs when new item added sent folder) , repeat process indefinitely, creating , moving copies until outlook forced closed. adding loop count check doesn't seem because script starts scratch each time item added.
below full code, there better way approach i'm doing? insight or direction appreciated!
edit: forgot add have code pasted in outlook's thisoutlooksession in vb developer tab (vbaproject.otm file)
private withevents items outlook.items private sub application_startup() dim olapp outlook.application set olapp = outlook.application set items = getns(olapp).getdefaultfolder(olfoldersentmail).items end sub private sub items_itemadd(byval item object) on error resume next msgbox "mail added sent folder, checking t-#" dim emailsub string dim emailsubarr variant dim projectnum string dim fullprojectnum string dim projnumlen long dim parentfoldername string dim subfoldername string if typename(item) = "mailitem" 'checks email subject project number tag if instr(item.subject, "t-") > 0 msgbox "t-# detected" 'splits out project number array extraction emailsub = item.subject emailsubarr = split(emailsub, chr(32)) = lbound(emailsubarr) ubound(emailsubarr) if instr(emailsubarr(i), "t-") > 0 fullprojectnum = emailsubarr(i) msgbox "t-# extracted" projnumlen = len(fullprojectnum) msgbox ("t-# " & projnumlen & " characters long") 'project number length check , formatting if projnumlen >= 11 exit sub end if if projnumlen <= 6 exit sub end if if projnumlen = 10 '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 'extended t-# format 1(ie t-38322x1) projectnum = right(fullprojectnum, 7) parentfoldername = left(projectnum, 2) subfoldername = left(projectnum, 7) end if if projnumlen = 8 'uncommon t-# format (ie t-38322a) projectnum = right(fullprojectnum, 6) parentfoldername = left(projectnum, 2) subfoldername = left(projectnum, 6) end if if projnumlen = 7 'standard t-# format (ie t-38322) projectnum = right(fullprojectnum, 5) parentfoldername = left(projectnum, 2) subfoldername = left(projectnum, 5) end if exit end if next msgbox ("confirm extraction (1 of 3) - project number t-" & projectnum) msgbox ("confirm extraction (2 of 3) - parent folder " & parentfoldername) msgbox ("confirm extraction (3 of 3) - sub folder " & subfoldername) msgbox ("will perform folder checks") 'perform folder checks, creates folders when needed dim fldrparent outlook.mapifolder dim fldrsub 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 nothing msgbox "parent folder not exist, creating folder" set fldrparent = outlook.session.folders("projects").folders("project root").folders.add(parentfoldername) else msgbox "parent folder exists, nothing" end if if fldrsub nothing msgbox "sub folder not exist, creating folder" set fldrsub = outlook.session.folders("projects").folders("project root").folders(parentfoldername).folders.add(subfoldername) else msgbox "sub folder exists, nothing" end if 'moves copy of email folder msgbox "copying sent email project folder" dim folderdest outlook.mapifolder dim myitem outlook.mailitem dim mycopieditem 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 outlook.application) outlook.namespace set getns = app.getnamespace("mapi") end function
add module level variable e.g. 'm_canceladd' , set value true before item.copy. @ beginnig of itemadd event handler check value of m_canceladd , if true reset , exit handler. hth.
private withevents items outlook.items private m_canceladd boolean private sub items_itemadd(byval item object) if (m_canceladd) m_canceladd = false exit sub end if dim mycopieditem 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 
Comments
Post a Comment