Easy archiving emails from Outlook

I’ve been experimenting with Outlook Macros to file messages to my single Archive box after processing, inspired by this recent lifehacker post. You’ll need to use the digital certificate process detailed in the above lifehacker post to ‘sign’ your macros.

These scripts work fine for messages that are selected in the Inbox - however I haven’t worked out how to make them work for the current message that you’ve opened up and have the focus on. When I installed the macro as a toolbar button on the open message, and clicked it - it operated on the message that I’d previously selected in the inbox - not the one that I’d just opened.

Any ideas?

This is my ‘ArchiveIt’ macro.

Sub Archive()
On Error Resume Next
Dim objFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

 

Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.Folders("Archive 2009").Folders("Archive")

If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is selected
Exit Sub
End If

For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.UnRead = False
objItem.Move objFolder
End If
End If
Next

Set objItem = Nothing
Set objFolder = Nothing
Set objNS = Nothing
End Sub

 

And this one is a TaskIt macro that creates a new task, attaches the message, and then files the original message to the archive folder as per the ArchiveIt macro.



Sub TaskItAndFile()
'Created by Jeremy Edmiston
'Point Loma Nazarene University
'Version 0.1.2
'Updated 7/24/03
'Modified by Andy B 24 Mar 09 to reduce functionality and support
'tasking-it for several items at once, and then file original messages

 

Dim oExplorer As Outlook.Explorer
Dim oMessage As Outlook.MailItem
Dim oTask As Outlook.TaskItem
Dim msgCount As Integer

Dim objFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Dim attPath As String

Set fs = CreateObject("Scripting.FileSystemObject")

Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.Folders("Archive 2009").Folders("Archive")
Set oExplorer = Outlook.ActiveExplorer.CurrentFolder.GetExplorer

attPath = "C:\temp"

If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is selected
Exit Sub
End If

msgCount = 0

Set oTask = Outlook.CreateItem(olTaskItem)

For Each Item In oExplorer.Selection 'Check items in current folder
msgCount = msgCount + 1 'increase counter
If oExplorer.Selection.Item(msgCount).Class = 43 Then 'Only do for Mail Items
Set oMessage = oExplorer.Selection.Item(msgCount)

With oTask

'Flag Handler
If oMessage.FlagStatus = 2 Then 'Message is flagged
Select Case oMessage.FlagRequest
Case "Follow up"
.Subject = "Follow up with " & oMessage.SenderName & _
" about " & oMessage.Subject & " (e-mail)"
Case "Call"
.Subject = "Call " & oMessage.SenderName & _
" about " & oMessage.Subject & " (e-mail)"
Case Else
'MsgBox oMessage.FlagRequest 'Not sure what this does
End Select
.ReminderSet = True
.ReminderTime = oMessage.FlagDueBy
.DueDate = oMessage.FlagDueBy
Else
If msgCount = 1 Then 'Set task title to that of first message in group
.Subject = oMessage.Subject
End If
End If

'Save Message Copy
oMessage.SaveAs attPath & oMessage.EntryID

'Attach Message Copy as Original Message
oTask.Attachments.Add attPath & oMessage.EntryID, olEmbeddeditem, , oMessage.Subject

'Delete temp file
fs.DeleteFile attPath & oMessage.EntryID, force

'Mark message as read, then move to archive
If objFolder.DefaultItemType = olMailItem Then
If oMessage.Class = olMail Then
oMessage.UnRead = False
oMessage.Move objFolder
End If
End If

'Display New Task
.Display
End With

End If
Next
End Sub