How to save forwarded emails sent as attachments into a separate folders based on keyword?

I have the macro below that saves an email when sent in the network drive based on the keyword in the body and subject.  

Now, If I forward multiple emails in my inbox or sent folder by holding Ctrl, the emails are sent as attachments.

I would like to modify the macro so that  each attached email to go to separate folders located in the network drive.

Thanks,
Sub processMai(ByVal Item As Object, Cancel As Boolean)
Dim itm As Variant
Dim saveFolder As MAPIFolder
'Const saveTo As String = "C:\Name"
Const saveTo As String = "C:\Name"
Dim subject As String
Dim intcount As Integer
Dim strSaveTo As String
Dim ret() As String
Dim entry As Variant
Dim foundit As Boolean
 
    If testStr(Item.subject) Then
        foundit = True
        extractStr Item.subject, ret
    Else
        If testStr(Item.Body) Then
            foundit = True
            extractStr Item.Body, ret
        End If
    End If
    If foundit Then
        For Each itm In ret
            Set saveFolder = olNav2Folder("\\Network Folder\Sent Items2\" & itm, True)
            strSaveTo = md(saveTo & "\" & itm, False)
                       subject = ""
            For intcount = 1 To Len(Item.subject)
                If Mid(Item.subject, intcount, 1) Like "[a-zA-Z0-9 ]" Then
                    subject = subject & Mid(Item.subject, intcount, 1)
                End If
            Next
            If strSaveTo <> "" Then
            Item.SaveAs strSaveTo & "\" & subject & " " & ".msg", olMSG
 
            End If
        Next
    End If
End Sub
 
 
Function md(dosPath As String, Optional createFolders As Boolean) As String
Dim fso As Object
Dim fldrs() As String
Dim rootdir As String
Dim fldrIndex As Integer
Dim bolret As Boolean
    
    md = ""
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(dosPath) Then
        fldrs = Split(dosPath, "\")
        rootdir = fldrs(0)
        If Not fso.FolderExists(rootdir) Then
            Exit Function
        End If
 
        bolret = True
        For fldrIndex = 1 To UBound(fldrs) - 1
            rootdir = rootdir & "\" & fldrs(fldrIndex)
            If Not fso.FolderExists(rootdir) Then
                If createFolders Then
                    fso.CreateFolder rootdir
                Else
                    bolret = False
                End If
            End If
        Next
        If bolret Then
            For Each fldr In fso.getfolder(rootdir).SubFolders
                If Left(fldr.Name, 2) = fldrs(UBound(fldrs)) Then
                    md = fldr.Path
                    Exit Function
                End If
            Next
        End If
        Exit Function
    End If
End Function
Function testStr(str As String) As String
Dim regEx As Object
    Set regEx = CreateObject("vbscript.regexp")
    With regEx
        .IgnoreCase = True
        .Pattern = ".*NC[0-9]{2}([0-9]{2})[0-9]{3}.*"
    End With
    testStr = regEx.test(str)
End Function
Function extractStr(str As String, ret() As String) As Boolean
Dim regEx As Object
Dim matches As Object
Dim cnt As Integer
    Set regEx = CreateObject("vbscript.regexp")
    With regEx
        .Global = True
        .IgnoreCase = True
        .Pattern = "NC[0-9]{2}[0-9]{2}[0-9]{3}"
    End With
    Set matches = regEx.Execute(str)
'MsgBox CStr(matches(0))
    If matches.Count = 0 Then
        extractStr = False
    Else
        extractStr = True
        For cnt = 0 To matches.Count - 1
            ReDim Preserve ret(0 To cnt)
            ret(cnt) = Mid(CStr(matches(cnt)), 5, 2)
        Next
    End If
End Function
 
 
 
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.Folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.Folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.Folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.Folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function
 
 
 
Dim WithEvents olkSentItems As Outlook.Items
 
Private Sub Application_Quit()
    Set olkSentItems = Nothing
End Sub
 
Private Sub Application_Startup()
    Set olkSentItems = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub
 
Private Sub olkSentItems_ItemAdd(ByVal Item As Object)
    processMai Item, False
End Sub

Open in new window

AmreskaAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

AmreskaAuthor Commented:
Hello,

Any help?

Amreska
0
Chris BottomleySoftware Quality Lead EngineerCommented:
I can look into it ... but may take a week or so for me as off hand I have only ideas and as I am on my hols ... !

Chris
0
David LeeCommented:
Hi, Amreska.

So you want the attached messages to be filed using the same keyword logic in the existing script.  Is that correct?
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

AmreskaAuthor Commented:
Hi BlueDevilFan:

Yes exactly as in the script.

Amreska
0
David LeeCommented:
What version of Outlook?
0
AmreskaAuthor Commented:
Outlook 2007
0
Chris BottomleySoftware Quality Lead EngineerCommented:
HAven't been able to treat the mails embedded in another mail in the same way so I'll leave you with David

Chris
0
AmreskaAuthor Commented:
Hi BlueDevilFan:

Any updates?.

Thanks,

Amreska
0
David LeeCommented:
Amreska,

Try replacing the subroutine processMai with the one below.  Test it thoroughly before putting it into production.  
Sub processMai(ByVal Item As Object, Cancel As Boolean)
Dim itm As Variant
Dim saveFolder As MAPIFolder
'Const saveTo As String = "C:\Name"
Const saveTo As String = "C:\Name"
Dim subject As String
Dim intcount As Integer
Dim strSaveTo As String
Dim ret() As String
Dim entry As Variant
Dim foundit As Boolean
Dim olkAttachment As Outlook.Attachment
Dim olkTemp As Outlook.MailItem
Dim strFilename As String
 
For Each olkAttachment In Item.Attachments
    strFilename = "C:\eeTesting\" & olkAttachment.FILENAME
    Set olkTemp = Application.CreateItemFromTemplate(strFilename)
    If testStr(olkTemp.subject) Then
        foundit = True
        extractStr olkTemp.subject, ret
    Else
        If testStr(olkTemp.Body) Then
            foundit = True
            extractStr olkTemp.Body, ret
        End If
    End If
    If foundit Then
        For Each itm In ret
            Set saveFolder = olNav2Folder("\\Network Folder\Sent Items2\" & itm, True)
            strSaveTo = md(saveTo & "\" & itm, False)
            subject = ""
            For intcount = 1 To Len(olkTemp.subject)
                If Mid(Item.subject, intcount, 1) Like "[a-zA-Z0-9 ]" Then
                    subject = subject & Mid(olkTemp.subject, intcount, 1)
                End If
            Next
            If strSaveTo <> "" Then
                olkAttachment.SaveAsFile strSaveTo & "\" & subject & " " & ".msg"
            End If
        Next
    End If
    Set olkTemp = Nothing
    Kill strFilename
Next
    If testStr(Item.subject) Then
        foundit = True
        extractStr Item.subject, ret
    Else
        If testStr(Item.Body) Then
            foundit = True
            extractStr Item.Body, ret
        End If
    End If
    If foundit Then
        For Each itm In ret
            Set saveFolder = olNav2Folder("\\Network Folder\Sent Items2\" & itm, True)
            strSaveTo = md(saveTo & "\" & itm, False)
                       subject = ""
            For intcount = 1 To Len(Item.subject)
                If Mid(Item.subject, intcount, 1) Like "[a-zA-Z0-9 ]" Then
                    subject = subject & Mid(Item.subject, intcount, 1)
                End If
            Next
            If strSaveTo <> "" Then
            Item.SaveAs strSaveTo & "\" & subject & " " & ".msg", olMSG
 
            End If
        Next
    End If
End Sub

Open in new window

0
AmreskaAuthor Commented:
Hi BlueDevil Fan:

I tried the macro and I got the following error message:

Run-Time error

Cannon open file" C:\eeTesting\Email Subject.msg.  The file may not exist, you may not have permission to open it, or it may be open in another program.  Right-click the folder that contains the file, and then click Properties to check your permissions for the folder.

When I click Debug

The following is highlighted:

Set olkTemp = Application.CreateItemFromTemplate(strFilename)
0
David LeeCommented:
Change the path name.  That was the path on my system.  Change it to use some folder on your system.
0
AmreskaAuthor Commented:
Hi BlueDevilFan:

I changed the path which is T:\PWS\Amro\Counties.

Then I got the following error message

Run-time error

Cannont open file: T:\PWS\Amro\CountiesSubject.msg.  The file may not exist, you may not have permission to open it, or it may be open in another program.  Right-click the folder that contains the file, and then click Properties to check your permissions to the folder.

When I click Debug, the following text is highlighted:

Set olkTemp = Application.CreateItemFromTemplate(strFilename)


0
David LeeCommented:
Is the file there?
0
AmreskaAuthor Commented:
BlueDevilFan:

There is nothing saved, I just receive the error message
0
AmreskaAuthor Commented:
The folder is available and is already created that includes all the keyword folders.

For example, I specify the location of T:\PWS\Amro/Counties. Under Counties folder there are 100 folders.  I want to save the attached emails in to one of those 100 folders based on the keyword of the in the subject heading of the attached emails.  As specified in the macro already.

The following is a summary on how the original macro works:

So if I have an email keyword in subject or body of NCXXYZXXX, then the macro will pick only the first two digits in the folder named YZ-Name.  The macro will ignore what the "Name" and will match only with YZ from the folder name.  "Name" is specifically associated with YZ.  Forexample, 01 will always be James, 02 will always be Michael.  So it does not matter what is included in "Names"

Further clarification that the digits YZ are any digit from 00 to 99, and "Name" in folder created in network drive is any word.

The reason I am naming the folders YZ-Name is because I want to specify what the digits actually mean for future reference, so that when I view the network folders I know what is the name that corresponds to each YZ digit.  Because each YZ has a unique name.
0
David LeeCommented:
I understand, but right now we aren't talking about the folders you want to file in.  We're only talking about the temp folder defined on line 17.  Outlook doesn't have a means of opening an attached message directly.  Instead, the code has to save it to disk and then read it back in.  That's the step that's failing right now.  Looking back at your post 24794842 I now see that you left the backslash off the the end of your folder path.  Line 17 should read

strFilename = "T:\PWS\Amro\Counties\" & olkAttachment.FILENAME

It'd be better to use a folder on your local drive for these temp files.
0
AmreskaAuthor Commented:
Hi BlueDevilFan:

I still get the same error if I include the local drive folders.

Thanks,

Amreska
0
David LeeCommented:
So you changed line 17 to save the temp file on the local computer, you made sure that the folder path you used ends with a \, and the file isn't saving.  Is that right?
0
AmreskaAuthor Commented:
BlueDevilFan:

Yes.

Thank You,
Amreska
0
David LeeCommented:
Does the attachment's filename contain any illegal characters (e.g. :, \, /, etc.)?
0
AmreskaAuthor Commented:
BlueDevilFan:

No it does not.  It only includes spaces.

Amreska
0
David LeeCommented:
Ok, I see the problem.  I left out the save command.  Insert this line between lines 17 and 18.

    olkAttachment.SaveAsFile strFilename
0
AmreskaAuthor Commented:
BlueDevilFan:

When I put the cursor on
  Set olkTemp = Application.CreateItemFromTemplate(strFilename)


attached email subject.msg is shown

Thanks

Amreska
0
AmreskaAuthor Commented:
Hi BlueDevilFan:

Its almost working.

I got the following issue:

The subject of the email file saved is not correct.  

Forexample,  I have an attached email subject of NC2563567 System Hanover, the following is the name of email saved:  NC563567 Sys
I would like the email saved file to have the heading of NC2563567 System Hanover instead of NC563567 Sys
The saved subject file name is not complete

Thanks,

Amreska
0
AmreskaAuthor Commented:
Hi BlueDevilFan:

Also, the forwarded email subject are saved in the network drive.  I want only the attached emails to be saved.

Thank You,

Amreska
0
David LeeCommented:
Ok, try this.

Sub processMai(ByVal Item As Object, Cancel As Boolean)
Dim itm As Variant
Dim saveFolder As MAPIFolder
'Const saveTo As String = "C:\Name"
Const saveTo As String = "C:\Name"
Dim subject As String
Dim intcount As Integer
Dim strSaveTo As String
Dim ret() As String
Dim entry As Variant
Dim foundit As Boolean
Dim olkAttachment As Outlook.Attachment
Dim olkTemp As Outlook.MailItem
Dim strFilename As String
 
For Each olkAttachment In Item.Attachments
    strFilename = "C:\eeTesting\" & olkAttachment.FILENAME
    olkAttachment.SaveAsFile strFilename
    Set olkTemp = Application.CreateItemFromTemplate(strFilename)
    If testStr(olkTemp.subject) Then
        foundit = True
        extractStr olkTemp.subject, ret
    Else
        If testStr(olkTemp.Body) Then
            foundit = True
            extractStr olkTemp.Body, ret
        End If
    End If
    If foundit Then
        For Each itm In ret
            Set saveFolder = olNav2Folder("\\Network Folder\Sent Items2\" & itm, True)
            strSaveTo = md(saveTo & "\" & itm, False)
            If strSaveTo <> "" Then
                olkAttachment.SaveAsFile strSaveTo & "\" & olkTemp.Subject & " " & ".msg"
            End If
        Next
    End If
    Set olkTemp = Nothing
    Kill strFilename
Next
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
AmreskaAuthor Commented:
Hi BlueDevilFan:

Thanks it works!.  

0
AmreskaAuthor Commented:
Hi BlueDevilFan:

Can you incorporate this macro with the original macro, so that I can use one macro to send emails with a specific keyword in the body or subject and also to forward emails?.

Thanks,

Amreska
0
David LeeCommented:
I'm a little confused.  It was all together in one macro until you said you wanted the name handled differently than in the first macro and didn't want to save the message.  If you can tell me how to figure out which macro to use for a given situation then I can put them together into one macro.  For example, do you want all messages with no attachments to use the original and all those with attachments to use the new macro?  Keep in mind that this would mean that a message with a Word attachment, for example,  would always use the second macro.  
0
AmreskaAuthor Commented:
Hi BlueDevilFan:

I would like to use the original macro if the is with or without attachments.  The new macro would be used only if there are email messages attached to the email.

Thanks,

Amreska
0
David LeeCommented:
Ok, let's try this.  Rename the first macro to processMai1.  Change the name of the second macro to processMai2.  Add the code below.  The code in the snippet checks to see if there are any attachments with an extension of "msg".  If there are, then it will run the new code.  If not, then it will run the original code.
Sub DecisionTree(Item As Outlook.MailItem)
    Dim olkAttachment As Outlook.Attachment, bolMsgAttachment As Boolean
    For Each olkAttachment In Item.Attachments
        If LCase(Right(olkAttachment.FILENAME, 3)) = "msg" Then
            bolMsgAttachment = True
            Exit For
        End If
    Next
    If bolMsgAttachment Then
        processMai2
    Else
        processMai1
    End If
    Set olkAttachment = Nothing
End Sub

Open in new window

0
AmreskaAuthor Commented:
Hi BlueDevilFan:

I received the following error in this outlook session:

Compile error:
Ambiguous name detected: processMai

Amreska
0
AmreskaAuthor Commented:
Hi BlueDevilFan:

This is what is included in the ThisOutlookSession:

Dim WithEvents olkSentItems As Outlook.Items
 
Private Sub Application_Quit()
    Set olkSentItems = Nothing
End Sub
 
Private Sub Application_Startup()
    Set olkSentItems = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub
 
Private Sub olkSentItems_ItemAdd(ByVal Item As Object)
    processMai Item, False
End Sub
0
AmreskaAuthor Commented:
When I change anything that says processMai to processMai1 and ProcessMai2, I get the following error in ThisOutlookSession:

Sub or Function not defined

and processMai is highlighted
0
David LeeCommented:
Did you get it worked out?
0
AmreskaAuthor Commented:
Yes Thank you very much
You are a genius indeed.

Amreska
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.