Macro for Customized Archiving

[raghuveer.v]

Hi,

I have come up with the following piece of code which works almost fine
except for a few hickups ... I need your help figuring out the same

Also, I believe this code will be useful for other looking for a
single-click solution to do the routine task of copying the old mails
from many folders in inbox to different PST folders

NOTE:
* The Archive() routine moves all unflagged items from a specified
SourceFolder to DestinationFolder
* The ArchiveMyMails() routine calls the above multiple times to move
mails from multiple folders to their respective backup folders (can
exist in different PST folders)
* The Function GetFolders() is not my original -- I picked it up from
these discussion forums
* I shall document the code properly once I am satisfied with the
functionality


Here's the code first ...

===============================================
'Raghuveer / 08 July 2006
---------------------------------------------------------------------------------------------

Sub ArchiveMyMails()
On Error Resume Next

Dim objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace

Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

Call Archive(objInbox, GetFolder("MyPersonalMails\Inbox"))
Call Archive(objInbox.Folders("Friends"),
GetFolder("MyPersonalMails\Inbox\Friends"))
Call Archive(objInbox.Folders("Personal"),
GetFolder("MyPersonalMails\Inbox\Personal"))
Call Archive(objInbox.Parent.Folders("Sent Items"),
GetFolder("MyPersonalMails\Sent Items"))

MsgBox "Archiving Complete!", vbOKOnly + vbExclamation,
"ArchiveMyMails: End"

End Sub

---------------------------------------------------------------------------------------------

Public Sub Archive(objSourceFolder As Outlook.MAPIFolder,
objDestinationFolder As Outlook.MAPIFolder)
On Error Resume Next

Dim objItem As Outlook.MailItem
Dim objReport As Outlook.ReportItem

Dim strPrompt As String
'Dim lngItemCount As Long
Dim lngResult As Long

strPrompt = "Do you want to move items" + vbCrLf + "FROM: " +
objSourceFolder.FolderPath + vbCrLf + "TO: " +
objDestinationFolder.FolderPath + " ?"
lngResult = MsgBox(strPrompt, vbYesNo + vbDefaultButton2 +
vbQuestion, "ArchiveMyMails: Confirm Movement")

If lngResult = vbNo Then
Exit Sub
End If

If objSourceFolder Is Nothing Then
MsgBox "Source folder doesn't exist!", vbOKOnly +
vbExclamation, "ArchiveMyMails: INVALID FOLDER"
Exit Sub
End If

If objDestinationFolder Is Nothing Or
objDestinationFolder.DefaultItemType <> olMailItem Then
MsgBox "Destination folder invalid!", vbOKOnly + vbExclamation,
"ArchiveMyMails: INVALID FOLDER"
Exit Sub
End If

'lngItemCount = 0

For Each objItem In objSourceFolder.Items
If objItem.Class = olMail And (objItem.FlagStatus = olNoFlag Or
objItem.FlagStatus = olFlagComplete) Then
objItem.Move objDestinationFolder
'lngItemCount = lngItemCount + 1
End If
Next

For Each objReport In
Application.ActiveExplorer.CurrentFolder.Items
If objItem.Class = olMail Then
objReport.Move objDestinationFolder
'lngItemCount = lngItemCount + 1
End If
Next

'MsgBox "Moved " + Str(lngItemCount) + " item(s)", vbOKOnly +
vbExclamation, "ArchiveMyMails: Report"

Set objItem = Nothing
Set objReport = Nothing
Set objSourceFolder = Nothing
Set objDestinationFolder = Nothing

End Sub

---------------------------------------------------------------------------------------------

Public Function GetFolder(strFolderPath As String) As MAPIFolder

' example of folder path : "MyPersonalMails\Inbox\Friends"

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

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

Now to the PROBLEM I am facing ...

[1] My Inbox folder currently has a number of mail items -- all flagged
(So there are no items for the macro to move). Whe I run the macro, If
i say YES to the movement of items from Inbox, it seems there's some
error in the background -- the macro does not go into other folders but
exits directly with the final report "Archiving Complete!"

[2] I wanted to also report the NUMBER of items moved from each folder.
I declared a counter and am trying to show a MsgBox with that count at
the end of each Archive() call ... but it is not working the way I want
-- it always shows "Moved 1 item(s)" when the folder has no items to be
moved. So I have disabled that part for now. (Note the commented out
lines in Archive())

Please help me with the above.

Thanks a lot in advance

~Raghuveer