Please help me perfect my archive macro...

[dewey1973]

This is my first attempt at an Outlook macro... so be gentle!

The purpose of this code is to take the selected message(s) and archive them into a deleted items archive or a sent items archive. There are folders for every year-month and the macro creates new folders if they do not exist. It works but not the way I hoped. Here is the code:

Sub Archive()
Dim Items As Selection
Dim Msg As MailItem
Dim NamSpace As NameSpace
Dim Proceed As VbMsgBoxResult
Dim moArchive, delArc, delArcMo, sentArc, sentArcMo As MAPIFolder
Dim newExp As Explorer

Set NamSpace = Application.GetNamespace("MAPI")
Set Items = ActiveExplorer.Selection

If Items.Count = 0 Then
Exit Sub
End If

For Each Msg In Items

On Error Resume Next

Set delArc = NamSpace.Folders("Mailbox - My Name") _
.Folders("Archive - Deleted Items") _
.Folders("Deleted " & Format(Msg.ReceivedTime, "YYYY"))

Set sentArc = NamSpace.Folders("Mailbox - My Name") _
.Folders("Archive - Sent Items") _
.Folders("Sent " & Format(Msg.ReceivedTime, "YYYY"))

If Msg.SenderName <> "My Name" Then
Msg.UnRead = False
Set moArchive = GetFolder("Mailbox - My Name\Archive - Deleted Items\Deleted " & Format(Msg.ReceivedTime, "YYYY") & "\Deleted " & Format(Msg.ReceivedTime, "YYYY-MM"))
If moArchive Is Nothing Then
delArc.Folders.Add ("Deleted " & Format(Msg.ReceivedTime, "YYYY-MM"))
Set delArcMo = delArc.Folders("Deleted " & Format(Msg.ReceivedTime, "YYYY-MM"))
Set newExp = delArcMo.GetExplorer
newExp.Activate
newExp.ShowPane olPreview, False
newExp.Close
Else
Set delArcMo = delArc.Folders("Deleted " & Format(Msg.ReceivedTime, "YYYY-MM"))
End If
Msg.Move delArcMo
Else
Msg.UnRead = False
Set moArchive = GetFolder("Mailbox - My Name\Archive - Sent Items\Sent " & Format(Msg.SentOn, "YYYY") & "\Sent " & Format(Msg.SentOn, "YYYY-MM"))
If moArchive Is Nothing Then
sentArc.Folders.Add ("Sent " & Format(Msg.SentOn, "YYYY-MM"))
Set sentArcMo = sentArc.Folders("Sent " & Format(Msg.SentOn, "YYYY-MM"))
Set newExp = sentArcMo.GetExplorer
newExp.Activate
newExp.ShowPane olPreview, False
newExp.Close
Else
Set sentArcMo = sentArc.Folders("Sent " & Format(Msg.SentOn, "YYYY-MM"))
End If
Msg.Move sentArcMo
End If
Next

End Sub

Here is the sub function I found on another site that I put to use in the code above:

Public Function GetFolder(strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"

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

The macro works, but when I select a large number of messages it does not process all of them. When I comment out the "On Error" to see what the problem is, I get an error:

Run-time Error '13':
Type mismatch

When I hit debug, the "Next" statement is indicated as the point of failure.

Can anyone help me perfect this macro?

[jfournier]

Are you sure all the items you are selecting are mailitem types? The error may be coming on the "next" statement because the next item of your collection is not of type mailitem (it may be appointmentitem or meetingitem that someone sent you).

If this is the problem you can declare Msg as type Object and the macro should be able to move the appointment/meeting items to the correct folders...

[dewey1973]

Are you sure all the items you are selecting are mailitem types? The error may be coming on the "next" statement because the next item of your collection is not of type mailitem (it may be appointmentitem or meetingitem that someone sent you).

If this is the problem you can declare Msg as type Object and the macro should be able to move the appointment/meeting items to the correct folders...

But since it is:
For Each Msg in Itrems

Shouldn't it ignore anything that is not a MailItem?

I only want to archive messages.

Also, if I run the macro again, or continue it from the editor after the debug, the macro will start running again and error again.

I can do this over and over until all of the messages in the selection get moved.

[jfournier]

I had some problems when iterating through an items collection in Outlook when the collection didn't hold just mailitems. When I changed the msg declaration to object and checked the object's type for every item in the items collection that stopped throwing errors. It might be worth a shot.

The problem with some items being left over may be with regards to the way to collection removes items (i.e. when you move them somewhere else). It may be that the one that was next drops to the current slot.

You may want to try a while loop, something like:
While Not items.Item(1) Is Nothing
If items.Item(1).SenderName = "whatever" Then
items.Item(1).Move whateverfolder
Else
items.Item(1).Move whateverfolder2
End If
Wend

This way you're essentially just draining the selection collection, though you'd have to do something to make sure you don't keep looping if you encounter an error processing the first item...

[dewey1973]

I put the While...Wend around the For...Next.

Now I get an occasional error of this type:
Run-time error '-555728891 (dee04005)':
The operation failed.

When I debug it goes to this line:
Msg.Move delArcMo

Again, I can step past it and run the macro until the next error occurs.
When I un-comment the On Error Resume Next the macro keeps looping as you mentioned above.

[jfournier]

I'm not sure what that error code is, but you may want to have your code make sure delArcMo isn't Nothing before sending the move command, or when debugging make sure the delArcMo folder isn't nothing...