Moving messages to folder in PST file.

  • Thread starter Thread starter Herb Cumbie
  • Start date Start date
H

Herb Cumbie

I need help making this work. I have users running Outlook 2000
connecting to mailboxes on a Exchange (v 5.0!!!) server. The goal is
to provide an easy (for the user) method for them to move selected
messages to a PST file for long term storage. Every user will be
configured with the same PST file information (each have identical but
separate PST files created in folders on a server). Ideally this
mechanism will be VBA code activated by a button assigned on the
toolbar. I found the following code, written by Kaitland Duck
Sherwood on the website for her book. It does almost exactly what we
need but the destination folder is located under the default Inbox. I
don't have enough experience to work my way through figuring out how
to access the correct folder in the PST file. I tried to do a couple
of things with the Folders object but can't seem to work it out.

Here's the code I'm starting with...

Option Explicit
' CREATED BY DUCKY SHERWOOD April 2001
' Original at http://www.webfoot.com/oeo/outlook/vb/OEOmacros.txt

' Move the selected message(s) to the "done" folder.
************************
Sub MoveToDone()
' Be sure to change the name of the "done" folder to the name of
' *your* "done" folder.
MoveToFolder ("zz-Done")
End Sub

' Move the selected message(s) to the "to-do" folder.
***********************
Sub MoveToToDo()
' Be sure to change the name of the "to-do" folder to the name of
' *your* "done" folder.
MoveToFolder ("aa-ToDo")
End Sub

' This sends an Up arrow and Alt-Up arrow key to Outlook.
' Up arrow moves the message selection bar up one when the list of
' messages is selected; Alt-Up does the same if a message is
' selected in the Preview pane. This is a bit of a kludge --
' it sends an two keystrokes when only one is needed -- but the extra
' keystroke doesn't seem to cause any bad side-effects. Furthermore,
it
' is really difficult to figure out which of the preview pane and
message
' list is active.
Sub MessageUp()
SendKeys "{UP}", True
SendKeys "%{UP}", True
End Sub

' Same as MessageUp, but with Down arrows instead.
Sub MessageDown()
SendKeys "{DOWN}", True
SendKeys "%{DOWN}", True
End Sub

' Returns TRUE if a folder named folderName is a child of the folder
' named parentFolder, FALSE otherwise. Note that if folderName is in
' a SUBfolder, this will return FALSE.
Function FolderExists(parentFolder As MAPIFolder, folderName As
String)
Dim tmpInbox As MAPIFolder

On Error GoTo handleError
' If the folder doesn't exist, there will be an error in the next
' line. That error will cause the error handler to go to
:handleError
' and skip the True return value

Set tmpInbox = parentFolder.Folders(folderName)
FolderExists = True
Exit Function
handleError:
FolderExists = False
End Function

' Move the selected message(s) to the given folder
**************************
Function MoveToFolder(folderName As String)

Dim myOLApp As Application
Dim myNameSpace As NameSpace
Dim myInbox As MAPIFolder
Dim currentMessage As MailItem
Dim errorReport As String


' Housekeeping: set up the macro environment
Set myOLApp = CreateObject("Outlook.Application")
Set myNameSpace = myOLApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)

' See if the folder exists. If it doesn't, print an informational
' error.
If Not FolderExists(myInbox, folderName) Then
MsgBox "Folder " & folderName & " does not exist." & _
vbNewLine & vbNewLine & _
"Please either: " & vbNewLine & vbNewLine & vbTab & _
"create the folder " & folderName & " under Inbox" &
vbNewLine & _
"or" & vbNewLine & vbTab & _
"change the name of the folder in the Visual Basic code "
& _
"that you downloaded. (The name of the folder is well
marked, " & _
"near the beginning of the code.)"
Exit Function
End If

' Figure out if the active window is a list of messages or one
message
' in its own window
On Error GoTo QuitIfError ' But if there's a problem, skip it
Select Case myOLApp.ActiveWindow.Class
' The active window is a list of messages (folder); this means
there
' might be several selected messages
Case olExplorer
' Move the selected messages to the "done" folder
For Each currentMessage In
myOLApp.ActiveExplorer.Selection
currentMessage.Move (myInbox.Folders(folderName))
Next

' The active window is a message window, meaning there will
only
' be one selected message (the one in this window)
Case olInspector
' Move the selected message to the "done" folder
myOLApp.ActiveInspector.CurrentItem.Move
(myInbox.Folders(folderName))
' can't handle any other kind of window; anything else will be
ignored
End Select

QuitIfError: ' Come here if there was some kind of problem
Set myOLApp = Nothing
Set myNameSpace = Nothing
Set myInbox = Nothing
Set currentMessage = Nothing
End Function
 
To get a non-default folder, you need to walk the folder hierarchy using the
Folders collections or use a function that does that for you. See
http://www.slipstick.com/dev/code/getfolder.htm

Consider building a COM add-in rather than using VBA for this, since there's
no easy mechanism to set up the VBA and toolbar button for users.
 
Ok, so I modified the code to use the getFolder() function. Stepping
through it in code view with watches set I see it pick up vales for
the various containers. They look correct to me (in this example I
have created a PST called "test" and it contains a folder called
"AutoArchive" that is the intended destination. I've left the
original calling parameters as they were but don't use them value
passed in the current version. It gets to the portion of the code
that should move the item and jumps to the end of the function... When
executed from the Outlook window with a message selected it does not
move the message...

Here's my modified code:

Option Explicit
' CREATED BY DUCKY SHERWOOD April 2001
' Butchered by Herb Cumbie February 2004
' Original at http://www.webfoot.com/oeo/outlook/vb/OEOmacros.txt

' Move the selected message(s) to the "done" folder.
Sub MoveToDone()
' Be sure to change the name of the "done" folder to the name of
' *your* "done" folder.
MoveToFolder ("zz-Done")
End Sub


' Move the selected message(s) to the given folder

Function MoveToFolder(folderName As String)

Dim myOLApp As Application
Dim myNameSpace As NameSpace
Dim myInbox As MAPIFolder
Dim currentMessage As MailItem
Dim errorReport As String
Dim objDestinationFolder As Outlook.MAPIFolder


' Housekeeping: set up the macro environment
Set myOLApp = CreateObject("Outlook.Application")
Set myNameSpace = myOLApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set objDestinationFolder = GetFolder("test/AutoArchive")

' Figure out if the active window is a list of messages or one
message
' in its own window
On Error GoTo QuitIfError ' But if there's a problem, skip it
Select Case myOLApp.ActiveWindow.Class
' The active window is a list of messages (folder); this means
there
' might be several selected messages
Case olExplorer
' Move the selected messages to the "done" folder
For Each currentMessage In
myOLApp.ActiveExplorer.Selection
currentMessage.Move (objDestinationFolder)
Next

' The active window is a message window, meaning there will
only
' be one selected message (the one in this window)
Case olInspector
' Move the selected message to the "done" folder
myOLApp.ActiveInspector.CurrentItem.Move
(objDestinationFolder)
' can't handle any other kind of window; anything else will be
ignored
End Select

QuitIfError: ' Come here if there was some kind of problem
Set myOLApp = Nothing
Set myNameSpace = Nothing
Set myInbox = Nothing
Set objDestinationFolder = Nothing
Set currentMessage = Nothing
End Function



Public Function GetFolder(strFolderPath As String) As MAPIFolder

' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long

On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))

If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing

End Function
 
Sue,

Thanks for the help. I think I'm making some progress, see my other
post with the revised code. It still does NOT move the message(s) to
the folder in the PST file so I'm not certain where to go from here.
But it does set the objects up as what should be the correct values
when I step through the code and watch the values of the objects.

The COM add-in would be great but ...

1. I don't know how to write a COM add-in, I'm almost over my head
working with VBA...
2. I need to get this "done" asap, the client is a control freak and
wants to implement this "immediately"...

I'm afraid that >> I <<< will be the "easy mechanism" to set up the
VBA and toolbar button for the users. Thank goodness it's only thirty
systems, should take more than half a day... (at least I'm a
contractor and bill for my hours <GRIN>)

Herb Cumbie
 
If you comment out your On Error statement, you'll get an idea of what the
problem is quicker. Either that, or check in the Immediate window for the
exact error or add a MsgBox or Debug.Print statement to the QuitIfError
section to tell you what's going on.

Is "test" the actual display name of the .pst file as seen in the folder
list? If not, adjust the path string to reflect the correct display name
*exactly* as you see it in the folder list.

Also note that you can't use a For Each loop to move items. Use a countdown
loop instead:

If Not objDestination Folder Is Nothing Then
intCount = myOLApp.ActiveExplorer.Selection.Count
For i = intCount to 1 Step -1
Set currentMessage = myOLApp.ActiveExplorer.Selection(i)
Set objMovedItem = currentMessage.Move(objDestinationFolder)
Next
End If
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
 
Sue,

Thanks for the help! Progress continues, albeit slowly...

I modified the code, replacing the portion that Ducky wrote to move
the messages with the one you provided...

The GOOD It will move the selected message to the intended
destination in the PST file (yes, the name was exactly as shown....)

Now the BAD If more than one message is selected it errors out
saying it cannot locate the message specified. This occurs on the
first pass into/through the loop that should move multiple messages if
they are selected... The counter is equal to the number of selected
messages... Here's the modified code as of this moment:

Option Explicit
' CREATED BY DUCKY SHERWOOD April 2001
' Butchered by Herb Cumbie February 2004
' Further Mangled by Herb Cumbie, gutting the original code
significantly
' Original at http://www.webfoot.com/oeo/outlook/vb/OEOmacros.txt

' Move the selected message(s) to the "done" folder.

Sub MoveToDone()
' Be sure to change the name of the "done" folder to the name of
' *your* "done" folder.
MoveToFolder ("zz-Done")
End Sub

' Move the selected message(s) to the given folder Function
MoveToFolder(folderName As String)

Dim myOLApp As Application
Dim myNameSpace As NameSpace
Dim myInbox As MAPIFolder
Dim currentMessage As MailItem
Dim errorReport As String
Dim objDestinationFolder As Outlook.MAPIFolder
Dim intCount As Integer
Dim I As Integer
Dim objMovedItem As MailItem



' Housekeeping: set up the macro environment
Set myOLApp = CreateObject("Outlook.Application")
Set myNameSpace = myOLApp.GetNamespace("MAPI")
Set objDestinationFolder = GetFolder("test/AutoArchive")

If Not objDestinationFolder Is Nothing Then
intCount = myOLApp.ActiveExplorer.Selection.Count
For I = intCount To 1 Step -1
Set currentMessage = myOLApp.ActiveExplorer.Selection(I)
Set objMovedItem =
currentMessage.Move(objDestinationFolder)
Next
End If

Set myOLApp = Nothing
Set myNameSpace = Nothing
Set objDestinationFolder = Nothing
Set currentMessage = Nothing
Set objMovedItem = Nothing


End Function



Public Function GetFolder(strFolderPath As String) As MAPIFolder

' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long

On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))

If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing

End Function
 
Which statement produces the error? If you step through the code do you have
valid objects at that point?

You probably ought to check the count first:

If myOLApp.ActiveExplorer.Selection.Count > 0 Then
' code to do the moving
End If

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
 
Sue,

Well, I got it to work. It seems to be a timing problem. A guy I
know who does a lot of VB programming had me insert a DoEvents call
into the loop and then it works with multiple selected messages!
Here's what that segment of code looks like now:

For I = intCount To 1 Step -1
Set currentMessage = myOLApp.ActiveExplorer.Selection(I)
Set objMovedItem = _
currentMessage.Move(objDestinationFolder)
DoEvents
Next I

Now that it works I need to implement one added "feature." As it
currently stands, no matter what container is the source the code
moves the selected message(s) to the destination folder. I need to
determine the current folder location of the selected message. If
it's the default InBox location then it will move it to the default
new location folder in the PST file. If it is in any other folder the
routine needs to (1) check for existance of a subfolder of that name
under the default destination and create one if not present and (2)
move the message to the corresponding destination subfolder. To do
this I need to know:

1. How to extract the folder name of the the folder containing the
selected items. The process should return the folder name as text.

2. How to check for the existance of a folder as a subfolder of the
default destination folder.

3. How to create a subfolder at the destination location if necessary.

Thanks again (and in advance) for all you're help!

Herb
 
Sue,

I want to thank you for the information and assistance you provided on
this issue. The final version of the code, implementing the
improvements I discussed is finished and has been successfully
deployed to the 30 users. I appreciate that rather than simply giving
me a coded solution to meet the objectives you provided the
information I needed to work through things on my own. I know that
without your asstance I would still be beating my head against the
brick walls trying to get this to work. Instead, my client's think I
great and really appreciate the functionality provided by the finished
project.

I am including the code to the final version in case someone else may
find it useful.

==================================================
NOTES:

The following code moves the selected message(s) to a designated
location. It was developed specifically to move messages to a folder
located in a PST file that is installed in the user's profile. In the
code below the destination location is specified by the folder path
information that is passed as a parameter in the call to the
MoveToFolder() function. In this example it is listed as
"test\AutoArchive" and should be changed to the path of the desired
destination as configured in the user profile. It is important that
the path be specified exactly as seen in the Folder view of Outlook.

This version of the code extends the orginal design objectives to a
moderate degree. The original design moved the messages to the
deisgnated folder irregardless of the original message container
location. This version moves messages from the default Inbox to the
designated location. If the message is located in any other folder a
subfolder by that name is created under the designated destination
folder location and the message is moved into the subfolder.

Limitations of this version:

1. It will move only mail messages. Any other type object will
generate a type mismatch error. Remember, receipts are NOT mail
messages.

2. It will create only one level of subfolders under the destination.
Therfore it will not exactly duplicate complex folder structures that
have several levels. For instance, given the following structure in
the mailbox origin:

Mailbox
\Inbox
\Category-1
\Category-2
\SubCat-A
\SubCat-B

Moving messages from all these folders to a PST folder at the path
"Perm Docs\Old Email" results in the following structure:

Perm Docs
\Old Email (items from Inbox)
\Category-1 (items from Category-1)
\Category-2 (items from Category-2)
\SubCat-A (items from SubCat-A)
\SubCat-B (items from SubCat-B)

Installation instructions:

Start Outlook
Access the Visual Basic Editor environment (ALT-F11 key)
Add a new blank module
Copy and paste the following code, starting with the Option Explicit
line into the new module workspace.
Modify the destination folder path information to fit your
configuration.
Save the project
Close the VB editor
Add a button to the toolbar of your choice to call the MoveToDone
macro.

==================================================


Option Explicit
' CREATED BY DUCKY SHERWOOD April 2001
' Butchered by Herb Cumbie February 2004
' Further Mangled by Herb Cumbie,
' who gutted the original code significantly
' Original at http://www.webfoot.com/oeo/outlook/vb/OEOmacros.txt

' Move the selected message(s) to the "done" folder.

Sub MoveToDone()
' Be sure to change the name of the "done" folder to the name of
' *your* "done" folder.
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
MoveToFolder ("test\AutoArchive")
End Sub

' Move the selected message(s) to the given folder Function

Function MoveToFolder(folderName As String)

Dim myOLApp As Application
Dim myNameSpace As NameSpace
Dim currentMessage As MailItem
Dim objDestinationFolder As Outlook.MAPIFolder
Dim objDestinationFolderRoot As Outlook.MAPIFolder
Dim strCurrentFolder As String
Dim strDestinationFolder As String
Dim strDestinationFolderRoot As String
Dim intCount As Integer
Dim I As Integer
Dim objMovedItem As MailItem



' Housekeeping: set up the macro environment
Set myOLApp = CreateObject("Outlook.Application")
Set myNameSpace = myOLApp.GetNamespace("MAPI")
strDestinationFolderRoot = folderName

' Check to see if destination root exists, if not exit
Set objDestinationFolderRoot = GetFolder(strDestinationFolderRoot)
If objDestinationFolderRoot Is Nothing Then
MsgBox ("Not connected to destination. Exiting!")
Exit Function
End If

' Get name of folder that contains selected message(s)
strCurrentFolder = myOLApp.ActiveExplorer.CurrentFolder.Name

' Check to see if destination contains a folder with same name
'
If Not strCurrentFolder = "Inbox" Then
strDestinationFolder = strDestinationFolderRoot + "\" + _
strCurrentFolder
Else
strDestinationFolder = strDestinationFolderRoot
End If

Set objDestinationFolder = GetFolder(strDestinationFolder)
If objDestinationFolder Is Nothing Then
objDestinationFolderRoot.Folders.Add (strCurrentFolder)
Set objDestinationFolder = GetFolder(strDestinationFolder)
End If


If Not objDestinationFolder Is Nothing Then
intCount = myOLApp.ActiveExplorer.Selection.Count
' If intCount > 1 Then
' MsgBox "Select only ONE message to move!"
' Else
' I = intCount
For I = intCount To 1 Step -1
Set currentMessage = myOLApp.ActiveExplorer.Selection(I)
Set objMovedItem = _
currentMessage.Move(objDestinationFolder)
DoEvents
Next I
' End If
End If

Set myOLApp = Nothing
Set myNameSpace = Nothing
Set objDestinationFolder = Nothing
Set currentMessage = Nothing
Set objMovedItem = Nothing


End Function



Public Function GetFolder(strFolderPath As String) As MAPIFolder

' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long

On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))

If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing

End Function
 
Herb, I'm glad you appreciate that some of us think it's important to "teach
a man to fish" rather than just serve up the catch of the day. Your next
project will go a lot faster and in no time at all, you'll be answering
questions that other people ask in these newsgroups!

If you like, feel free to also post the code to the sample library at
http://www.outlookcode.com/codeupload.aspx?area=2 where it will be available
for ready reference in the future.
 
Back
Top