Link to home
Start Free TrialLog in
Avatar of Amreska
Amreska

asked on

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

Avatar of Amreska
Amreska

ASKER

Hello,

Any help?

Amreska
Avatar of Chris Bottomley
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
Hi, Amreska.

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

ASKER

Hi BlueDevilFan:

Yes exactly as in the script.

Amreska
What version of Outlook?
Avatar of Amreska

ASKER

Outlook 2007
HAven't been able to treat the mails embedded in another mail in the same way so I'll leave you with David

Chris
Avatar of Amreska

ASKER

Hi BlueDevilFan:

Any updates?.

Thanks,

Amreska
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

Avatar of Amreska

ASKER

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)
Change the path name.  That was the path on my system.  Change it to use some folder on your system.
Avatar of Amreska

ASKER

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)


Is the file there?
Avatar of Amreska

ASKER

BlueDevilFan:

There is nothing saved, I just receive the error message
Avatar of Amreska

ASKER

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.
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.
Avatar of Amreska

ASKER

Hi BlueDevilFan:

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

Thanks,

Amreska
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?
Avatar of Amreska

ASKER

BlueDevilFan:

Yes.

Thank You,
Amreska
Does the attachment's filename contain any illegal characters (e.g. :, \, /, etc.)?
Avatar of Amreska

ASKER

BlueDevilFan:

No it does not.  It only includes spaces.

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

    olkAttachment.SaveAsFile strFilename
Avatar of Amreska

ASKER

BlueDevilFan:

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


attached email subject.msg is shown

Thanks

Amreska
Avatar of Amreska

ASKER

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
Avatar of Amreska

ASKER

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
ASKER CERTIFIED SOLUTION
Avatar of David Lee
David Lee
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Amreska

ASKER

Hi BlueDevilFan:

Thanks it works!.  

Avatar of Amreska

ASKER

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
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.  
Avatar of Amreska

ASKER

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
SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Amreska

ASKER

Hi BlueDevilFan:

I received the following error in this outlook session:

Compile error:
Ambiguous name detected: processMai

Amreska
Avatar of Amreska

ASKER

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
Avatar of Amreska

ASKER

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
Did you get it worked out?
Avatar of Amreska

ASKER

Yes Thank you very much
You are a genius indeed.

Amreska