Here is some event code that should work. It will take any email that comes in with the subject line starting "Ticket #" and look for a matching folder under the "Aprimo Support" folder. If it doesn't exist, it will be created before the email is moved. The code assumes that "Aprimo Support" is a subfolder one level below the Inbox.
This code is untested (I wrote it in Notepad), so you should set some break points in the code to test it out. This code should be pasted in the ThisOutlookSession module of the Outlook VBIDE. Also you should turn off the rule, it could interfere with the VBA event.
Private WithEvents MyItems As Outlook.Items
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Set objNS = GetNamespace("MAPI")
Set MyItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub MyItems_ItemAdd(ByVal item As Object)
Dim Msg As Outlook.MailItem
Dim strTicketNum As String
Dim FolderToMove As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
If TypeOf item Is Outlook.MailItem Then
Set Msg = item
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
If Left$(Msg.Subject, 8) = "Ticket #" Then
strTicketNum = Mid$(Msg.Subject, 10, 8) ' Folder name
If CheckForFolder(strTicketNum) = False Then ' Folder doesn't exist
Set FolderToMove = CreateSubFolder(strTicketNum)
Else
Set FolderToMove = olInbox.Folders("Aprimo Support").Folders(strTicketNum)
End If
Msg.Move FolderToMove
End If
End If
ExitProc:
Set Msg = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set FolderToMove = Nothing
End Sub
Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
On Error Resume Next
Set FolderToCheck = olInbox.Folders("Aprimo Support").Folders(strFolder)
On Error Goto 0
If Not FolderTocheck Is Nothing Then
CheckForFolder = True
End If
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that the folder doesn't exist
' returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set CreateSubFolder = olInbox.Folders("Aprimo Support").Folders.Add(strFolder)
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
--JP
Originally Posted by
ssmith001
When I open a new case with a vendor of ours, I get a barrage of emails over time that deal with each of the unique case numbers. What I am looking for is some help with some code that would read the subject line, looking for "Ticket #" which is then followed by a unique number for this ticket. What I then want to do is to create a subfolder for that ticket number (if one doesn't already exist) and then file each of the emails I receive automatically in the correct folder.
Example:
Subject Line: Ticket # 00044862: [ref:00D3jPA.50085KBiC:ref] - Project Type has two listings
would get filed in a folder called "Ticket 44862".
I have an Outlook rule that moves all these messages into a folder called "Aprimo Support" but this folder is getting out of control and is difficult to manage.
I am using Outlook 2003.
Reply With Quote
