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:
[vba]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
[/vba]
Here is the sub function I found on another site that I put to use in the code above:
[vba]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
[/vba]
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?