How to save incoming or sent emails with a specific keyword into a specific folder

You can use Rules to save them in different folders in your Outlook (which is also on your disk)
Why do you want them on your hard drive (C Drive)?

Gary

I can use outlook folders or hard drive.  Because I send 100 emails at once, each sent email will have a keyword such as "County".  Therefore, I want to save the email with "county" keyword into the "county" folder either in the outlook folders or hard drive.  More than one folder will be listed in outlook and I want to automatically save an email with a specific keyword to its corresponding folder.

I don't believe I can accomplish this using Rule option in Outlook.

Thanks,

First of all, you definitely want to do it in Outlook Folders.
Secondly I still don't unterstand why you don't think you can set up Rules to do what you want.

Ok.  You are right.  I now have 100 folders that I want to create.  How do I create 100 folders at once in outlook.  I don't want to create 100 folders one by one.  Then  I will use the Rule option to link the specific keywork in the incoming or sent email to one of the 100 created folders.

Thank You,

How would you identify the list of keywords?

Chris

Hi Chris,

I already know the keywords that I want to use.  I have a hundred of keywords.  I want to create a hundred
folders in Outlook at once.  Then I want to link the email keyword to one of the 100 folders.

Thanks

Amreska

Not sure why you need two questions for this?

1. Creating the folders, can do but under what folder path and given a constant I assume you will enter the folder names therein?

2. Do you really want to create hundreds of rules?, I was assuming a script to create folders and move the emails on receipt / sending.

Chris

Looks like I responded in the other thread.  PLease take a look, and perhaps delete this duplicate thread?

Chris

Maybe this will help creating the rules

http://support.microsoft.com/kb/292063

Gary

Amro

In order to code in a save folder can you advise the DOS folder root for the emails?  I am assuming you want sub directories as per the PST folders albeit in the OS folder structure ... and these sub folders must have a root.

Chris

In the following code, replace strkeywords as before and additionally:
Const saveTo As String = "c:\deleteme"
to point to the DOS/network folder where you want the emails copying ... sub folders will be created.

It replaces processMai as supplid earlier and requires the additional sub md that follows it to be inserted as well.

Chris

Sub processMai(ByVal Item As Object, Cancel As Boolean)
Const strkeywords As String = "fred, doris"
Dim arrKeywords() As String
Dim varKeywords As Variant
Dim dicKeyWords As Object
Dim itm As Variant
Dim saveFolder As MAPIFolder
Const saveTo As String = "c:\deleteme"
Dim subject As String
Dim intcount As Integer
 
'    strkeywords = Replace(strkeywords, ", ", ",")
    arrKeywords = Split(Replace(strkeywords, ", ", ","), ",")
    Set dicKeyWords = CreateObject("scripting.dictionary")
    For Each itm In arrKeywords
        If Not dicKeyWords.Exists(LCase(itm)) Then dicKeyWords.Add LCase(itm), itm
    Next
    varKeywords = dicKeyWords.items     ' Definitely only one set of each keyword
    
    For Each itm In arrKeywords
        If InStr(LCase(Item.body), LCase(itm)) > 0 Or InStr(LCase(Item.subject), LCase(itm)) > 0 Then
            Set saveFolder = olNav2Folder(Application.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "\" & itm, True)
            md saveTo & "\" & itm, True
            Set Item.SaveSentMessageFolder = saveFolder
            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 Item.BodyFormat = olFormatHTML Then
                    Item.SaveAs saveTo & "\" & itm & "\" & subject & " " & Item.EntryID & ".htm", olHTML
                ElseIf Item.BodyFormat = olFormatRichText Then
                    mai.Item saveTo & "\" & itm & "\" & subject & " " & Item.EntryID & ".rtf", olRTF
                Else
                    mai.Item saveTo & "\" & itm & "\" & subject & " " & Item.EntryID & ".msg", olMsg
                End If
        End If
    Next
 
End Sub
Function md(dosPath As String, Optional createFolders As Boolean)
Dim fso As Object
Dim fldrs() As String
Dim rootdir As String
Dim fldrIndex As Integer
    
    md = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(dosPath) Then
        fldrs = Split(dosPath, "\")
        rootdir = fldrs(0)
        If Not fso.FolderExists(rootdir) Then
            md = False
            Exit Function
        End If
 
        For fldrIndex = 1 To UBound(fldrs)
            rootdir = rootdir & "\" & fldrs(fldrIndex)
            If Not fso.FolderExists(rootdir) Then
                If createFolders Then
                    fso.CreateFolder rootdir
                Else
                    md = False
                End If
            End If
        Next
        Exit Function
    End If
End Function

Select all Open in new window

Hi Chris,

The macro you provided does not save the email on the hard drive nor does it create a folder based on the keyword.

Thanks

I presume you changed saveTo.

I am sure I tested it before but i'll have to run some tests to make sure the principle works before looking deeper.

Chris

Hi Chris,

Do I need to add macro for "ThisOutlookSession"

Thanks

You should already have the entry in thisoutlooksession from the previous question.   All this does is enhance the sub called by thisoutlooksession to have teh additional save function for DOS files.

Chris

Chris,

When I input the following in ThisOultookSession:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    App_ItemSend_3 Item, Cancel
End Sub

I get the following error:

Complie error:
Sub or Function not defined


Also, the App_ItemSend_3 is highlighted

Thanks

That sub should also pre-exist from the earlier question, (I presume you cleaqred out in readiness for this Question ... but I have assumed you kept it all) and is:

Sub App_ItemSend_3(ByVal Item As Object, Cancel As Boolean)
    processMai Item, Cancel
End Sub

Chris

Chris,

Do I add both Subs?:
Sub App_ItemSend_3(ByVal Item As Object, Cancel As Boolean)
    processMai Item, Cancel
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    App_ItemSend_3 Item, Cancel
End Sub

Chris,

I added the following code by itself:
Sub App_ItemSend_3(ByVal Item As Object, Cancel As Boolean)
    processMai Item, Cancel
End Sub


Still, it does not save either in my outlook files or in hard drive.

Try adding a line to each sub to see when they are called:

Execution should stop in each sub ... and give some idea of progress, press F5 when it stops noting the sub names and it will continue to the next one.

Chris

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    stop
    App_ItemSend_3 Item, Cancel
End Sub
 
Sub App_ItemSend_3(ByVal Item As Object, Cancel As Boolean)
    stop
    processMai Item, Cancel
End Sub
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    stop
    App_ItemSend_3 Item, Cancel
End Sub

Select all Open in new window

Chris,

I received error:

Compile error:  Ambiguous name detected: Application_ItemSend

for the following sub:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    stop
    App_ItemSend_3 Item, Cancel
End Sub

Chris,

Any news?

I was asleep!

This looks as though you have two copies of Application_ItemSend.  There should only be one and that must reside in thisoutlooksession.  DO a search on current project for the name and you should delete the wrong one(s) making sure thisoutlooksession is kept and has the defined line therein.

You didn't say which line though so if there is only one then I expect the same for App_ItemSend_3 Item ... this time it resides in a normal code module but there still must only be one copy for it to work in this way ... can work around if you need multilple subs of same name but easiest to avoid

Chris

Chris,

I don't understand what are you trying to get out of the itemsend_3 and  the reason for adding lines for itemsend_3?

Thanks

Chris,

I am having difficulty following your instructions.  Will you please provide a step by step procedure.

Thank You

Ambiguous name detected: Application_ItemSend  means there are two copies of a sub called Ambiguous name detected: Application_ItemSend .

You need to find and delete the extra copy.

You should have ONE copy in thisoutlloksession and this is the one to keep.

Chris

Chris,

I tried one by one and found only the following does not give an error.

Sub App_ItemSend_3(ByVal Item As Object, Cancel As Boolean)
    stop
    processMai Item, Cancel
End Sub

The other two give the followign error:

Compile error:

Sub or Function not defined

>>> I tried one by one and found only the following does not give an error.

I don't understand ... it is >>> Application_ItemSend   <<< that is being reported for the error not App_ItemSend_3.  The point being there shall be only ONE COPY of  Application_ItemSend ANYWHERE.  Is this true or false?

Similarly there ought to be only one copy of any other subs, but since you state that the error relates to  Application_ItemSend  that ought to be it.

Chris

Chris,

I did the following :

1) added the following in ThisOutlookSession:
Sub App_ItemSend_3(ByVal Item As Object, Cancel As Boolean)
    Stop
    processMai Item, Cancel
End Sub
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Stop
    App_ItemSend_3 Item, Cancel
End Sub

2) I pressed F5 after each stop, then the following error was displayed:

Compile error:  Sub or Function not defined

Also, olNav2Folder was highlighted in the Macro Module.

There is only one App_ItemSend and is found in the ThisOutlookSession Macro.


Thanks for your cooperation

Can you upload each code module contents clearly seperating them out so I can look them over?, it'll be easier than trying to picture what is happening.

Chris

Module

Sub processMai(ByVal Item As Object, Cancel As Boolean)
Const strkeywords As String = "Wake"
Dim arrKeywords() As String
Dim varKeywords As Variant
Dim dicKeyWords As Object
Dim itm As Variant
Dim saveFolder As MAPIFolder
Const saveTo As String = "C:\"
Dim subject As String
Dim intcount As Integer
 
'    strkeywords = Replace(strkeywords, ", ", ",")
    arrKeywords = Split(Replace(strkeywords, ", ", ","), ",")
    Set dicKeyWords = CreateObject("scripting.dictionary")
    For Each itm In arrKeywords
        If Not dicKeyWords.Exists(LCase(itm)) Then dicKeyWords.Add LCase(itm), itm
    Next
    varKeywords = dicKeyWords.Items     ' Definitely only one set of each keyword
    
    For Each itm In arrKeywords
        If InStr(LCase(Item.Body), LCase(itm)) > 0 Or InStr(LCase(Item.subject), LCase(itm)) > 0 Then
            Set saveFolder = olNav2Folder(Application.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "\" & itm, True)
            md saveTo & "\" & itm, True
            Set Item.SaveSentMessageFolder = saveFolder
            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 Item.BodyFormat = olFormatHTML Then
                    Item.SaveAs saveTo & "\" & itm & "\" & subject & " " & Item.EntryID & ".htm", olHTML
                ElseIf Item.BodyFormat = olFormatRichText Then
                    mai.Item saveTo & "\" & itm & "\" & subject & " " & Item.EntryID & ".rtf", olRTF
                Else
                    mai.Item saveTo & "\" & itm & "\" & subject & " " & Item.EntryID & ".msg", olMSG
                End If
        End If
    Next
 
End Sub
Function md(dosPath As String, Optional createFolders As Boolean)
Dim fso As Object
Dim fldrs() As String
Dim rootdir As String
Dim fldrIndex As Integer
    
    md = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(dosPath) Then
        fldrs = Split(dosPath, "\")
        rootdir = fldrs(0)
        If Not fso.FolderExists(rootdir) Then
            md = False
            Exit Function
        End If
 
        For fldrIndex = 1 To UBound(fldrs)
            rootdir = rootdir & "\" & fldrs(fldrIndex)
            If Not fso.FolderExists(rootdir) Then
                If createFolders Then
                    fso.CreateFolder rootdir
                Else
                    md = False
                End If
            End If
        Next
        Exit Function
    End If
End Function

Select all Open in new window

ThisOutlookSession

Sub App_ItemSend_3(ByVal Item As Object, Cancel As Boolean)
    stop
    processMai Item, Cancel
End Sub
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    stop
    App_ItemSend_3 Item, Cancel
End Sub

Select all Open in new window

Chris,

I get run time error message: Run-time error '424' Object required

And the following line is highlighted in the module:
mai.Item saveTo & "\" & itm & "\" & subject & " " & Item.EntryID & ".msg", olMSG

SHeesh, how much more can be wrong!

Sorry about this, it's pretty much bread and butter to me so I can't believe the issues.  I have modified processMai below the rest of the code should be ok as is

Chris

Sub processMai(ByVal Item As Object, Cancel As Boolean)
Const strkeywords As String = "Wake"
Dim arrKeywords() As String
Dim varKeywords As Variant
Dim dicKeyWords As Object
Dim itm As Variant
Dim saveFolder As MAPIFolder
Const saveTo As String = "C:\"
Dim subject As String
Dim intcount As Integer
 
'    strkeywords = Replace(strkeywords, ", ", ",")
    arrKeywords = Split(Replace(strkeywords, ", ", ","), ",")
    Set dicKeyWords = CreateObject("scripting.dictionary")
    For Each itm In arrKeywords
        If Not dicKeyWords.Exists(LCase(itm)) Then dicKeyWords.Add LCase(itm), itm
    Next
    varKeywords = dicKeyWords.Items     ' Definitely only one set of each keyword
    
    For Each itm In arrKeywords
        If InStr(LCase(Item.Body), LCase(itm)) > 0 Or InStr(LCase(Item.subject), LCase(itm)) > 0 Then
            Set saveFolder = olNav2Folder(Application.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "\" & itm, True)
            md saveTo & "\" & itm, True
            Set Item.SaveSentMessageFolder = saveFolder
            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 Item.BodyFormat = olFormatHTML Then
                    Item.SaveAs saveTo & "\" & itm & "\" & subject & " " & Item.EntryID & ".htm", olHTML
                ElseIf Item.BodyFormat = olFormatRichText Then
                    Item.SaveAs saveTo & "\" & itm & "\" & subject & " " & Item.EntryID & ".rtf", olRTF
                Else
                    Item.SaveAs saveTo & "\" & itm & "\" & subject & " " & Item.EntryID & ".msg", olMSG
                End If
        End If
    Next
 
End Sub

Select all Open in new window

Chris,

Thank You.  One more thing.  The emails saved have a weird naming.  Can the names of the emails saved be the exact subject heading?.

Thank You

I used the entry ID to generate a unique heading but if you are happy for the latest email to overwrite an earlier one with the same subject then that is easy enough but they need invalid chharacters removing so they will often be different to the actual subject string due to these exclusions


Chris

Chris,

The heading is currently fine.  How about spaces for the file name.  There are no spaces between words in the name of the file saved.

Thanks,
Amro

Chris,

Thank you very much.  I just noticed that the outlook message saved in the folders have a note that says "This message has not been sent".  Why this message is displayed.  For legal purposes, I would like a proof that the messages were sent to the appropriate recepients.

Thank You

In strict terms, the mails being saved to DOS are pre send hence they are available to process.  Because the mail has not been sent at that instant it is not sent for another few milliseconds or whatever.

Chris

Chris,

Ok.  Is the subffolders created in outlook under the Sent Items also linked to the network drive I specified in the macro?.  If not, is there a way to create folders that are linked to the network drive instead of local drive as I specified in the macro?

Thank You

The file saved in sent items is by default linked to the PST wherever it is in the network.  If on the other hand your PST is not network based then you will need to create a suitable PST on the network drive and then we can make another change to save the files on the network PST.

Chris

Chris,

I don't believe PST is network based.  How to create a suitable PST and save files on the network pst?.

Thanks

I guess that the answers the question as to whether the PST is network based then, in outlook:

File | data mangement | data files tab | Add Button selecting PST
Select the network drive where you want it to be and give a useful name.

When that activity is complete you have a second PST associated with outlook and the files can saved there.

You need to create the folder structure down to the parent for these mails then let me know the folder path via Selectiong the folder in the PST then in the immediate window typing:

?application.ActiveExplorer.CurrentFolder.FolderPath

Chris

Chris,

will you please provide a step by step procedure on how get the folder path.

Thank You,

1. Select the folder in the Outlook folder explorer.
2. In the immediate window of the VBE type:
     ?application.ActiveExplorer.CurrentFolder.FolderPath
3. Upload the string here

Chris

Chris:
\\Network Folder

Let me know if that is correct.

Amro

Chris:

Its actually this one:

\\Network Folder\Sent Items2
\\Network Folder