Macro for Customized Archiving

R

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 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
* Currently, the Archive() routine moves all unflagged items from
SourceFolder to DestinationFolder

Here's the code first ...

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

Sub ArchiveMyMails()
On Error Resume Next

'Dim myOLApp As Application
'Dim strCurrentFolder As String

'Set myOLApp = CreateObject("Outlook.Application")
'strCurrentFolder = myOLApp.ActiveExplorer.CurrentFolder.Name

'If strCurrentFolder = "Inbox" Then strDestinationFolder =
"MyPersonalMails\Inbox"
'If strCurrentFolder = "Friends" Then strDestinationFolder =
"MyPersonalMails\Inbox\Friends"
'If strCurrentFolder = "Personal" Then strDestinationFolder =
"MyPersonalMails\Inbox\Personal"
'If strCurrentFolder = "Sent Items" Then strDestinationFolder =
"MyPersonalMails\Sent Items"
'If strCurrentFolder = "Sara Lee" Then strDestinationFolder =
"MyWork\Sara Lee"
'If strCurrentFolder = "Sara Lee Transformation" Then
strDestinationFolder = "MyWork\Sara Lee Transformation"

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 in advance

~Raghuveer
 
M

Michael Bauer

Am 8 Jul 2006 06:44:46 -0700 schrieb (e-mail address removed):

Here´re some errors in the Archive method found on a first look:

If objDestinationFolder is nothing then calling one of its properties the
same line would cause an error.

If you want to move items off a collection then you must loop backwards
through it.

Actually there´s no need to loop twice. And I don´t understand why you loop
through ActiveExplorer.CurrentFolder the second time, that´s probably not a
specified source folder.

You could loop once and check the item type. Usually you´d declare a
variable as Object for the loop.

Just due to the On Error Resume Next statement you don´t get an error while
using objReport for a loop through MailItem objects (and vice versa). And if
you really have a ReportItem then its Class property is olReport not olMail.


--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.VBOffice.net --

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 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
* Currently, the Archive() routine moves all unflagged items from
SourceFolder to DestinationFolder

Here's the code first ...

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

Sub ArchiveMyMails()
On Error Resume Next

'Dim myOLApp As Application
'Dim strCurrentFolder As String

'Set myOLApp = CreateObject("Outlook.Application")
'strCurrentFolder = myOLApp.ActiveExplorer.CurrentFolder.Name

'If strCurrentFolder = "Inbox" Then strDestinationFolder =
"MyPersonalMails\Inbox"
'If strCurrentFolder = "Friends" Then strDestinationFolder =
"MyPersonalMails\Inbox\Friends"
'If strCurrentFolder = "Personal" Then strDestinationFolder =
"MyPersonalMails\Inbox\Personal"
'If strCurrentFolder = "Sent Items" Then strDestinationFolder =
"MyPersonalMails\Sent Items"
'If strCurrentFolder = "Sara Lee" Then strDestinationFolder =
"MyWork\Sara Lee"
'If strCurrentFolder = "Sara Lee Transformation" Then
strDestinationFolder = "MyWork\Sara Lee Transformation"

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 in advance

~Raghuveer
Click to expand...
 
R

raghuveer.v

Hi Mike,

Thanks a lot for the inputs.

Here's my modified code ...

=================================================
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 2\Inbox"))
Call Archive(objInbox.Folders("Friends"),
GetFolder("MyPersonalMails 2\Inbox\Friends"))
Call Archive(objInbox.Folders("Personal"),
GetFolder("MyPersonalMails 2\Inbox\Personal"))
Call Archive(objInbox.Parent.Folders("Sent Items"),
GetFolder("MyPersonalMails 2\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 Object
Dim intObjCount As Integer
Dim intCounter As Integer

Dim strPrompt As String
Dim intMovedItemCount As Integer
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 Then
If objDestinationFolder.DefaultItemType <> olMailItem Then
MsgBox "Destination folder invalid!", vbOKOnly +
vbExclamation, "ArchiveMyMails: INVALID FOLDER"
Exit Sub
End If
End If

intMovedItemCount = 0

intObjCount = objSourceFolder.Items.Count

For intCounter = intObjCount To 1 Step -1
objItem = objSourceFolder.Items(intCounter)
If (objSourceFolder.Items(intCounter).Class = olMail) Then
If (objSourceFolder.Items(intCounter).FlagStatus = olNoFlag
Or objSourceFolder.Items(intCounter).FlagStatus = olFlagComplete) Then
objSourceFolder.Items(intCounter).Move
objDestinationFolder
intMovedItemCount = intMovedItemCount + 1
End If
End If
If (objSourceFolder.Items(intCounter).Class = olReport) Then
objSourceFolder.Items(intCounter).Move
objDestinationFolder
intMovedItemCount = intMovedItemCount + 1
End If
Next


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

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

End Sub

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

Your code review really helped -- a couple of errors have been
eliminated.

Now ...

[#] Inbox is still a problem -- whenever I say YES to move items from
Inbox, it exits directly without going into other folders

[#] The count of messages moved is twice that of the correct figure --
for example, if it moves 3 messages, it reports as 6!

[#] Please let me know the class types for meeting / appointment
requests -- I want to move them too

Thanks a lot once again,

~Raghuveer

Michael said:
Am 8 Jul 2006 06:44:46 -0700 schrieb (e-mail address removed):

Here´re some errors in the Archive method found on a first look:

If objDestinationFolder is nothing then calling one of its properties the
same line would cause an error.

If you want to move items off a collection then you must loop backwards
through it.

Actually there´s no need to loop twice. And I don´t understand why you loop
through ActiveExplorer.CurrentFolder the second time, that´s probably not a
specified source folder.

You could loop once and check the item type. Usually you´d declare a
variable as Object for the loop.

Just due to the On Error Resume Next statement you don´t get an error while
using objReport for a loop through MailItem objects (and vice versa). Andif
you really have a ReportItem then its Class property is olReport not olMail.


--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.VBOffice.net --

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 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
* Currently, the Archive() routine moves all unflagged items from
SourceFolder to DestinationFolder

Here's the code first ...

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

Sub ArchiveMyMails()
On Error Resume Next

'Dim myOLApp As Application
'Dim strCurrentFolder As String

'Set myOLApp = CreateObject("Outlook.Application")
'strCurrentFolder = myOLApp.ActiveExplorer.CurrentFolder.Name

'If strCurrentFolder = "Inbox" Then strDestinationFolder =
"MyPersonalMails\Inbox"
'If strCurrentFolder = "Friends" Then strDestinationFolder =
"MyPersonalMails\Inbox\Friends"
'If strCurrentFolder = "Personal" Then strDestinationFolder =
"MyPersonalMails\Inbox\Personal"
'If strCurrentFolder = "Sent Items" Then strDestinationFolder =
"MyPersonalMails\Sent Items"
'If strCurrentFolder = "Sara Lee" Then strDestinationFolder =
"MyWork\Sara Lee"
'If strCurrentFolder = "Sara Lee Transformation" Then
strDestinationFolder = "MyWork\Sara Lee Transformation"

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 in advance

~Raghuveer
Click to expand...
Click to expand...
 
M

Michael Bauer

Am 8 Jul 2006 11:46:55 -0700 schrieb (e-mail address removed):

Please delete the On Error Resume Next (or make it a comment) and go through
the code step by step (F8). What happens?

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.VBOffice.net --

Hi Mike,

Thanks a lot for the inputs.

Here's my modified code ...

=================================================
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 2\Inbox"))
Call Archive(objInbox.Folders("Friends"),
GetFolder("MyPersonalMails 2\Inbox\Friends"))
Call Archive(objInbox.Folders("Personal"),
GetFolder("MyPersonalMails 2\Inbox\Personal"))
Call Archive(objInbox.Parent.Folders("Sent Items"),
GetFolder("MyPersonalMails 2\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 Object
Dim intObjCount As Integer
Dim intCounter As Integer

Dim strPrompt As String
Dim intMovedItemCount As Integer
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 Then
If objDestinationFolder.DefaultItemType <> olMailItem Then
MsgBox "Destination folder invalid!", vbOKOnly +
vbExclamation, "ArchiveMyMails: INVALID FOLDER"
Exit Sub
End If
End If

intMovedItemCount = 0

intObjCount = objSourceFolder.Items.Count

For intCounter = intObjCount To 1 Step -1
objItem = objSourceFolder.Items(intCounter)
If (objSourceFolder.Items(intCounter).Class = olMail) Then
If (objSourceFolder.Items(intCounter).FlagStatus = olNoFlag
Or objSourceFolder.Items(intCounter).FlagStatus = olFlagComplete) Then
objSourceFolder.Items(intCounter).Move
objDestinationFolder
intMovedItemCount = intMovedItemCount + 1
End If
End If
If (objSourceFolder.Items(intCounter).Class = olReport) Then
objSourceFolder.Items(intCounter).Move
objDestinationFolder
intMovedItemCount = intMovedItemCount + 1
End If
Next


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

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

End Sub

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

Your code review really helped -- a couple of errors have been
eliminated.

Now ...

[#] Inbox is still a problem -- whenever I say YES to move items from
Inbox, it exits directly without going into other folders

[#] The count of messages moved is twice that of the correct figure --
for example, if it moves 3 messages, it reports as 6!

[#] Please let me know the class types for meeting / appointment
requests -- I want to move them too

Thanks a lot once again,

~Raghuveer

Michael said:
Am 8 Jul 2006 06:44:46 -0700 schrieb (e-mail address removed):

Here´re some errors in the Archive method found on a first look:

If objDestinationFolder is nothing then calling one of its properties the
same line would cause an error.

If you want to move items off a collection then you must loop backwards
through it.

Actually there´s no need to loop twice. And I don´t understand why you loop
through ActiveExplorer.CurrentFolder the second time, that´s probably not a
specified source folder.

You could loop once and check the item type. Usually you´d declare a
variable as Object for the loop.

Just due to the On Error Resume Next statement you don´t get an error while
using objReport for a loop through MailItem objects (and vice versa). And if
you really have a ReportItem then its Class property is olReport not olMail.


--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.VBOffice.net --

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 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
* Currently, the Archive() routine moves all unflagged items from
SourceFolder to DestinationFolder

Here's the code first ...

===============================================
'Raghuveer / 08 July 2006
Click to expand...
---------------------------------------------------------------------------------------------
Sub ArchiveMyMails()
On Error Resume Next

'Dim myOLApp As Application
'Dim strCurrentFolder As String

'Set myOLApp = CreateObject("Outlook.Application")
'strCurrentFolder = myOLApp.ActiveExplorer.CurrentFolder.Name

'If strCurrentFolder = "Inbox" Then strDestinationFolder =
"MyPersonalMails\Inbox"
'If strCurrentFolder = "Friends" Then strDestinationFolder =
"MyPersonalMails\Inbox\Friends"
'If strCurrentFolder = "Personal" Then strDestinationFolder =
"MyPersonalMails\Inbox\Personal"
'If strCurrentFolder = "Sent Items" Then strDestinationFolder =
"MyPersonalMails\Sent Items"
'If strCurrentFolder = "Sara Lee" Then strDestinationFolder =
"MyWork\Sara Lee"
'If strCurrentFolder = "Sara Lee Transformation" Then
strDestinationFolder = "MyWork\Sara Lee Transformation"

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
Click to expand...
---------------------------------------------------------------------------------------------
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
Click to expand...
---------------------------------------------------------------------------------------------
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 in advance

~Raghuveer
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Macro for Customized Archiving 0
Senders email address in saved attachment 1
For Each loop not getting all Email Items 3
copying a custom view from a public folder and distributing programatically 1
Operation Failed, object could be not be found - Can't find the fo 2
Type mismatch when moving mail item from sent items 1
Word macro that can call cells out of Excel for a find and replace 0
Finding a .pst file I have just renamed 1

Top