Solved

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

Posted on 2009-06-29
36
391 Views
Last Modified: 2012-05-07
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

0
Comment
Question by:Amreska
  • 21
  • 13
  • 2
36 Comments
 

Author Comment

by:Amreska
ID: 24739066
Hello,

Any help?

Amreska
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 24745624
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
 
LVL 76

Expert Comment

by:David Lee
ID: 24748378
Hi, Amreska.

So you want the attached messages to be filed using the same keyword logic in the existing script.  Is that correct?
0
 

Author Comment

by:Amreska
ID: 24748491
Hi BlueDevilFan:

Yes exactly as in the script.

Amreska
0
 
LVL 76

Expert Comment

by:David Lee
ID: 24748628
What version of Outlook?
0
 

Author Comment

by:Amreska
ID: 24748662
Outlook 2007
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 24783862
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
 

Author Comment

by:Amreska
ID: 24787047
Hi BlueDevilFan:

Any updates?.

Thanks,

Amreska
0
 
LVL 76

Expert Comment

by:David Lee
ID: 24792520
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
 

Author Comment

by:Amreska
ID: 24794711
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
 
LVL 76

Expert Comment

by:David Lee
ID: 24794747
Change the path name.  That was the path on my system.  Change it to use some folder on your system.
0
 

Author Comment

by:Amreska
ID: 24794842
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
 
LVL 76

Expert Comment

by:David Lee
ID: 24795275
Is the file there?
0
 

Author Comment

by:Amreska
ID: 24795491
BlueDevilFan:

There is nothing saved, I just receive the error message
0
 

Author Comment

by:Amreska
ID: 24795543
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
 
LVL 76

Expert Comment

by:David Lee
ID: 24795653
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
 

Author Comment

by:Amreska
ID: 24795799
Hi BlueDevilFan:

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

Thanks,

Amreska
0
 
LVL 76

Expert Comment

by:David Lee
ID: 24795837
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
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 

Author Comment

by:Amreska
ID: 24795933
BlueDevilFan:

Yes.

Thank You,
Amreska
0
 
LVL 76

Expert Comment

by:David Lee
ID: 24796164
Does the attachment's filename contain any illegal characters (e.g. :, \, /, etc.)?
0
 

Author Comment

by:Amreska
ID: 24796341
BlueDevilFan:

No it does not.  It only includes spaces.

Amreska
0
 
LVL 76

Expert Comment

by:David Lee
ID: 24796409
Ok, I see the problem.  I left out the save command.  Insert this line between lines 17 and 18.

    olkAttachment.SaveAsFile strFilename
0
 

Author Comment

by:Amreska
ID: 24796458
BlueDevilFan:

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


attached email subject.msg is shown

Thanks

Amreska
0
 

Author Comment

by:Amreska
ID: 24796556
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
 

Author Comment

by:Amreska
ID: 24796661
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
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 24798130
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
 

Author Comment

by:Amreska
ID: 24798340
Hi BlueDevilFan:

Thanks it works!.  

0
 

Author Comment

by:Amreska
ID: 24798349
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
 
LVL 76

Expert Comment

by:David Lee
ID: 24798439
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
 

Author Comment

by:Amreska
ID: 24799574
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
 
LVL 76

Assisted Solution

by:David Lee
David Lee earned 500 total points
ID: 24799772
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
 

Author Comment

by:Amreska
ID: 24803197
Hi BlueDevilFan:

I received the following error in this outlook session:

Compile error:
Ambiguous name detected: processMai

Amreska
0
 

Author Comment

by:Amreska
ID: 24805077
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
 

Author Comment

by:Amreska
ID: 24805105
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
 
LVL 76

Expert Comment

by:David Lee
ID: 24805891
Did you get it worked out?
0
 

Author Comment

by:Amreska
ID: 24830527
Yes Thank you very much
You are a genius indeed.

Amreska
0

Featured Post

Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

Join & Write a Comment

Granting full access permission allows users to access mailboxes present in their database. By giving full access permission one can open and read the content of any mailbox but cannot send emails from that mailbox.
Are you unable to connect or configure Hotmail email account in Microsoft Outlook 2010, 2007? Or Outlook.com emails are not downloading to Outlook? Lets’ see the problem and resolve Outlook Connector error syncing folder hierarchy (0x8004102A).
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now