Solved

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

Posted on 2009-06-29
36
399 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
Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

 

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
 

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

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Outlook Free & Paid Tools
If you don't know how to downgrade, my instructions below should be helpful.
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

770 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