Under construction
'Tag !Next and move'
Public Sub SetNext()
SetTag "!Next"
MoveSelectedItemsToFolder "_Ongoing"
End Sub
'Tag @Someday and move'
Public Sub SetSomeday()
SetTag "@Someday"
MoveSelectedItemsToFolder "_Ongoing"
'Tag Reference and move'
Public Sub SetWaiting()
SetTag "Waiting"
MoveSelectedItemsToFolder "_Ongoing"
End Sub
End Sub
'Tag Reference and move'
Public Sub SetReference()
SetTag "Reference"
MoveSelectedItemsToFolder "_Ongoing"
End Sub
'Tag Reference and Archive'
Public Sub Done()
SetTag "Done"
MoveSelectedItemsToFolder "Archive"
End Sub
Private Sub SetTag(Tag As String)
Dim objOutlook As Outlook.Application
Dim objInspector As Outlook.Inspector
Dim strDateTime As String
' Instantiate an Outlook Application object.
Set objOutlook = CreateObject("Outlook.Application")
' The ActiveInspector is the currently open item.
Set objExplorer = objOutlook.ActiveExplorer
' Check and see if anything is open.
If Not objExplorer Is Nothing Then
' Get the current item.
Dim arySelection As Object
Set arySelection = objExplorer.Selection
For x = 1 To arySelection.Count
strCats = arySelection.Item(x).Categories
If Not strCats = "" Then
strCats = strCats & ","
End If
strCats = strCats & Tag
arySelection.Item(x).Categories = strCats
arySelection.Item(x).Save
Next x
Else
' Show error message with only the OK button.
MsgBox "No explorer is open", vbOKOnly
End If
' Set all objects equal to Nothing to destroy them and
' release the memory and resources they take.
Set objOutlook = Nothing
Set objExplorer = Nothing
End Sub
Private Sub MoveSelectedItemsToFolder(FolderName As String)
On Error GoTo ErrorHandler
Dim Namespace As Outlook.Namespace
Set Namespace = Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Set Inbox = Namespace.GetDefaultFolder(olFolderInbox)
Dim Folder As Outlook.MAPIFolder
Set Folder = Inbox.Folders(FolderName)
If Folder Is Nothing Then
MsgBox "The '" & FolderName & "' folder doesn't exist!", _
vbOKOnly + vbExclamation, "Invalid Folder"
End If
Dim Item As Object
For Each Item In Application.ActiveExplorer.Selection
If Item.UnRead Then Item.UnRead = False
Item.Move Folder
Next
Exit Sub
ErrorHandler:
MsgBox Error(Err)
End Sub
