UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> Macro To Move Validated Emails By Subject Not Triggering, Office 2013    
 
   
chrismbaylis
post Oct 2 2017, 12:21 PM
Post#1



Posts: 75
Joined: 25-March 10



Hi folks,

I receive, on a daily basis, many hundreds of system generated emails that start with the subject line "New Post in [client name] : [project code and name]". My aim, is to parse the subject line of all emails that come in, and if they start with "New Post in" extract the client name, determine if a folder exists in the "__Client Projects" directory, and if so move it there - if not, create a new folder and put the email there.

My code, which is in the "ThisOutlookSession"module is as follows:

CODE
Public WithEvents Items As Outlook.Items
Public Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set Items = objNS.Folders("cbaylisXXXYYYZZZ").Folders("Inbox").Items
End Sub
Public Sub Items_ItemAdd(ByVal item As Object)
    On Error GoTo ErrorHandler
    Dim msg As Outlook.MailItem
    Dim strClient As String
    Dim destFolder As Outlook.MAPIFolder
    If TypeName(item) = "MailItem" Then
        Set msg = item
         ' check if subject field contains "New Post in"
        If InStr(msg.Subject, "New Post in ") > 0 Then
            'extract the client name - between 'New Post in' and the colon
            strClient = Trim$(Mid$(msg.Subject, 13, InStr(1, " : ", msg.Subject, vbTextCompare) - 13))
            On Error Resume Next
            Set destFolder = Outlook.Session.Folders("cbaylisXXXYYYZZZ").Folders("Inbox").Folders("__Client Projects")
            ' if subfolder doesn't exist, create it
            If destFolder.Folders(strClient) Is Nothing Then
                destFolder.Folders.Add (strClient)
            End If
            ' move msg to subfolder
            msg.Move destFolder.Folders(strClient)
            Debug.Print "Message regarding '" & strClient & "' moved to relevant client folder.", vbOKOnly + vbInformation, "Rules Notice"
            MsgBox "Message regarding '" & strClient & "' moved to relevant client folder.", vbOKOnly + vbInformation, "Rules Notice"
        End If
    End If
ProgramExit:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub


Whilst the code compiles without error, and I have closed and opened Outlook since writing the script, for some reason, I can't get it to trigger.

Am I missing something?

Thanks in advance for your help.

Chris
(Using Exchange, if that matters)
Go to the top of the page
 
chrismbaylis
post Oct 3 2017, 01:09 PM
Post#2



Posts: 75
Joined: 25-March 10



So, for anyone who is interested in using this approach, it turns out there were two errors.

The first (schoolboy blush.gif ) error: check macro security!!!!! - Now fixed

The second error, was that when checking to see if the folder exists, because of the way MAPI folders are referenced (inside the PST file), you need to check to see if an error is thrown when looking to see if a folder exists.

If you search around, the web will tell you that you have to parse through your entire folders collection to throw the error - if you pass it enough to begin with - you don't - but you do have to wrap the instruction in 'IsError' wrappers, as shown below.

This code is tested (with macros enabled crazy.gif ) and proven to work with both new clients and existing (creates a new client folder, and references an existing one correctly).

Feel free to use as needed.

CODE
Public WithEvents Items As Outlook.Items
Public Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set Items = objNS.Folders("cbaylisXXXYYYZZZ").Folders("Inbox").Items
End Sub
Public Sub Items_ItemAdd(ByVal item As Object)
    On Error GoTo ErrorHandler
    Dim msg As Outlook.MailItem
    Dim strClient As String
    Dim destFolder As Outlook.MAPIFolder
    If TypeName(item) = "MailItem" Then
        Set msg = item
         ' check if subject field contains "New Post in"
        If InStr(1, msg.Subject, "New Post in ") > 0 Then
            'extract the client name - between 'New Post in' and the colon
            strClient = Trim$(Mid$(msg.Subject, 13, InStr(1, msg.Subject, " : ", vbTextCompare) - 13))
            On Error Resume Next
            Set destFolder = Outlook.Session.Folders("cbaylisXXXYYYZZZ").Folders("Inbox").Folders("__Client Projects")
            ' if subfolder doesn't exist, create it
            If IsError(destFolder.Folders(strClient) Is Nothing) Then      '<----this is the important bit: IsError()!!!!!
                destFolder.Folders.Add (strClient)
            End If
            ' move msg to subfolder
            msg.Move destFolder.Folders(strClient)
            Debug.Print "Message regarding '" & strClient & "' moved to relevant client folder."     '<---- QA step - delete if you don't need it
        End If
    End If
ProgramExit:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

This post has been edited by chrismbaylis: Oct 3 2017, 01:10 PM
Go to the top of the page
 


Custom Search
RSSSearch   Top   Lo-Fi    17th October 2017 - 06:17 AM