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,
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
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
Chris
Hi, Amreska.
So you want the attached messages to be filed using the same keyword logic in the existing script. Is that correct?
So you want the attached messages to be filed using the same keyword logic in the existing script. Is that correct?
ASKER
Hi BlueDevilFan:
Yes exactly as in the script.
Amreska
Yes exactly as in the script.
Amreska
What version of Outlook?
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
Chris
ASKER
Hi BlueDevilFan:
Any updates?.
Thanks,
Amreska
Any updates?.
Thanks,
Amreska
Amreska,
Try replacing the subroutine processMai with the one below. Test it thoroughly before putting it into production.
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
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.CreateItemFrom Template(s trFilename )
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.CreateItemFrom
Change the path name. That was the path on my system. Change it to use some folder on your system.
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\CountiesSubjec t.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.CreateItemFrom Template(s trFilename )
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\CountiesSubjec
When I click Debug, the following text is highlighted:
Set olkTemp = Application.CreateItemFrom
Is the file there?
ASKER
BlueDevilFan:
There is nothing saved, I just receive the error message
There is nothing saved, I just receive the error message
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.
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.
strFilename = "T:\PWS\Amro\Counties\" & olkAttachment.FILENAME
It'd be better to use a folder on your local drive for these temp files.
ASKER
Hi BlueDevilFan:
I still get the same error if I include the local drive folders.
Thanks,
Amreska
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?
ASKER
BlueDevilFan:
Yes.
Thank You,
Amreska
Yes.
Thank You,
Amreska
Does the attachment's filename contain any illegal characters (e.g. :, \, /, etc.)?
ASKER
BlueDevilFan:
No it does not. It only includes spaces.
Amreska
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
olkAttachment.SaveAsFile strFilename
ASKER
BlueDevilFan:
When I put the cursor on
Set olkTemp = Application.CreateItemFrom Template(s trFilename )
attached email subject.msg is shown
Thanks
Amreska
When I put the cursor on
Set olkTemp = Application.CreateItemFrom
attached email subject.msg is shown
Thanks
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
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
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
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
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Hi BlueDevilFan:
Thanks it works!.
Thanks it works!.
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
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.
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
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
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Hi BlueDevilFan:
I received the following error in this outlook session:
Compile error:
Ambiguous name detected: processMai
Amreska
I received the following error in this outlook session:
Compile error:
Ambiguous name detected: processMai
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(o lFolderSen tMail).Ite ms
End Sub
Private Sub olkSentItems_ItemAdd(ByVal Item As Object)
processMai Item, False
End Sub
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(o
End Sub
Private Sub olkSentItems_ItemAdd(ByVal
processMai Item, False
End Sub
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
Sub or Function not defined
and processMai is highlighted
Did you get it worked out?
ASKER
Yes Thank you very much
You are a genius indeed.
Amreska
You are a genius indeed.
Amreska
ASKER
Any help?
Amreska