Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

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

Posted on 2009-05-17
50
Medium Priority
?
311 Views
Last Modified: 2013-12-14
I want to create a macro that will allow saving  sent or incoming emails with specifiic keywords in the body of the email such as "County", or "System Number".  The sent  or incoming emails will then be saved in the hard drive into a specific created folder.  For example, sent or incoming email with "county" keyword in the body of the email will be automatically saved in to the "County" Folder in the hard drive.  In addition, Incoming or sent emails with "System Number" in the body of the email will be automatically saved in the "System Number" folder in the hard drive.  And so forth.

The software I use is Outlook 2007.

Thank you for your cooperation.

Amro Ali


0
Comment
Question by:Amreska
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 25
  • 22
  • 3
50 Comments
 
LVL 46

Expert Comment

by:tbsgadi
ID: 24406364
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
0
 

Author Comment

by:Amreska
ID: 24406425
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,
0
 
LVL 46

Expert Comment

by:tbsgadi
ID: 24406437
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.
0
Office 365 Training for IT Pros

Learn how to provision tenants, synchronize on-premise Active Directory, implement Single Sign-On, customize Office deployment, and protect your organization with eDiscovery and DLP policies.  Only from Platform Scholar.

 

Author Comment

by:Amreska
ID: 24406485
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,
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 24406679
How would you identify the list of keywords?

Chris
0
 

Author Comment

by:Amreska
ID: 24406876
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
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 24409246
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
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 24418590
Looks like I responded in the other thread.  PLease take a look, and perhaps delete this duplicate thread?

Chris
0
 
LVL 46

Expert Comment

by:tbsgadi
ID: 24420111
Maybe this will help creating the rules

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

Gary
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 24458098
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
0
 
LVL 59

Expert Comment

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

Open in new window

0
 

Author Comment

by:Amreska
ID: 24468748
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
0
 
LVL 59

Expert Comment

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

Author Comment

by:Amreska
ID: 24472670
Hi Chris,

Do I need to add macro for "ThisOutlookSession"

Thanks
0
 
LVL 59

Expert Comment

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

Author Comment

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

0
 
LVL 59

Expert Comment

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

Author Comment

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



0
 

Author Comment

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


0
 
LVL 59

Expert Comment

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

Open in new window

0
 

Author Comment

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

0
 

Author Comment

by:Amreska
ID: 24477370
Chris,

Any news?
0
 
LVL 59

Expert Comment

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

Author Comment

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

Author Comment

by:Amreska
ID: 24483408
Chris,

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

Thank You
0
 
LVL 59

Expert Comment

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

Author Comment

by:Amreska
ID: 24484742
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
0
 
LVL 59

Expert Comment

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

Author Comment

by:Amreska
ID: 24485836
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
0
 
LVL 59

Expert Comment

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

Author Comment

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

Open in new window

0
 

Author Comment

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

Open in new window

0
 
LVL 59

Assisted Solution

by:Chris Bottomley
Chris Bottomley earned 2000 total points
ID: 24486107
In the module add the sub below and let me know how it goes.

Chris
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

Open in new window

0
 

Author Comment

by:Amreska
ID: 24486206
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
0
 
LVL 59

Expert Comment

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

Open in new window

0
 

Author Comment

by:Amreska
ID: 24487664
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
0
 
LVL 59

Expert Comment

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

Author Comment

by:Amreska
ID: 24492836
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
0
 
LVL 59

Assisted Solution

by:Chris Bottomley
Chris Bottomley earned 2000 total points
ID: 24494570
That is an unforunate oversight that should be corrected here:

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

Open in new window

0
 

Author Comment

by:Amreska
ID: 24494719
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
0
 
LVL 59

Expert Comment

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

Author Comment

by:Amreska
ID: 24495285
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
0
 
LVL 59

Expert Comment

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

Author Comment

by:Amreska
ID: 24495447
Chris,

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

Thanks
0
 
LVL 59

Expert Comment

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

Author Comment

by:Amreska
ID: 24495895
Chris,

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

Thank You,
0
 
LVL 59

Expert Comment

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

Author Comment

by:Amreska
ID: 24497709
Chris:
\\Network Folder

Let me know if that is correct.

Amro
0
 

Author Comment

by:Amreska
ID: 24497774
Chris:

Its actually this one:

\\Network Folder\Sent Items2
\\Network Folder
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 2000 total points
ID: 24497949
Whilst I cannot test since I do not have the PST, (I could create one but for each Q these things become impossible to administer).

I think I have it correct in the modified processMai below.

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("\\Network Folder\Sent Items2\" & 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

Open in new window

0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

This article helps those who get the 0xc004d307 error when trying to rearm (reset the license) Office 2013 in a Virtual Desktop Infrastructure (VDI) and/or those trying to prep the master image for Microsoft Key Management (KMS) activation. (i.e.- C…
This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
The viewer will learn how to  create a slide that will launch other presentations in Microsoft PowerPoint. In the finished slide, each item launches a new PowerPoint presentation and when each is finished it automatically comes back to this slide: …
Do you want to know how to make a graph with Microsoft Access? First, create a query with the data for the chart. Then make a blank form and add a chart control. This video also shows how to change what data is displayed on the graph as well as form…

670 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