Solved

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

Posted on 2009-05-17
50
299 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
  • 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
 

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
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 
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 500 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 500 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 500 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

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

PaperPort has a feature called the "Send To Bar". It provides a convenient, drag-and-drop interface for using other installed software, such as Microsoft Office. However, this article shows that the latest Office 2016 apps (installed with an Office …
No matter the version of Windows you are using, you may have some problems with Windows Search running too slow or possibly not running at all. Before jumping into how you can solve this issue, just know there are many other viable alternative deskt…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

705 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

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now