Getting Things Done: Files & Macros

Sub Task()
    ' This macro takes a mail/post/RSS item,
    ' allows you to (re)assign a category and create a task-like name
    ' for it, moves it into the task folder, and then opens the new
    ' task for further editing.  In other words, this approximates
    ' the functionality of dragging a mail item to the task icon in Outlook.

    ' Dim item As MailItem
        ' Commented out to "generalize the macro"
        ' Now it runs on PostItems and RssItems
    Dim myolApp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    'Dim fileFolder As Outlook.Folder
    Dim newName As String

    Select Case TypeName(Outlook.Application.ActiveWindow)
        Case "Explorer"
            Set item = Outlook.Application.ActiveExplorer.Selection.item(1)
        Case "Inspector"
            Set item = Outlook.Application.ActiveInspector.CurrentItem
        Case Else
            '
    End Select

    ' Mark as unread
    item.UnRead = False
    item.Save

    ' Categorize & rename it
    item.ShowCategoriesDialog
    newName = InputBox("Please enter a subject for the task:", "Task Subject", item.Subject)
    ' Code I came across for OL07 uses the property .TaskSubject
    ' One of the annoying changes in OL07 are all these new fields that look the
    ' same as OL02/OL03 fields, but aren't really....
    item.Subject = newName
    item.Save

    ' Move it to the default task folder
    Set myolApp = CreateObject("Outlook.Application")
    Set myNamespace = myolApp.GetNamespace("MAPI")
    Set myTasks = myNamespace.GetDefaultFolder(olFolderTasks)
    newItem = item.Move(myTasks)

    ' Find the new task and open it
    Set myItems = myTasks.Items
    Set myItem = myItems.Find("[Subject] = '" + newName + "'")
    While TypeName(myItem) <> "Nothing"
        myItem.Display
        Set myItem = myItems.FindNext
    Wend
End Sub

Sub SetCategory(MyCategory As String)
    ' Adds MyCategory to the category list for the current item

    Set objApp = CreateObject("Outlook.Application")
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
            If GetCurrentItem.Categories = "" Then
                GetCurrentItem.Categories = MyCategory
            Else
                GetCurrentItem.Categories = GetCurrentItem.Categories & "," & MyCategory
            End If
            GetCurrentItem.MarkAsTask (4)
            GetCurrentItem.Save
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
            If GetCurrentItem.Categories = "" Then
                GetCurrentItem.Categories = MyCategory
            Else
                GetCurrentItem.Categories = GetCurrentItem.Categories & "," & MyCategory
            End If
            GetCurrentItem.MarkAsTask (4)
        Case Else
            ' anything else will result in an error, which is
            ' why we have the error handler above
    End Select

    Set objApp = Nothing
End Sub

Sub MoveSelectedMessagesToFolder(FolderName As String)
    ' Moves the selected message to FolderName, which must be a
    ' subfolder of the default inbox

On Error Resume Next
    Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
    Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem, objPost As Outlook.PostItem

    Set objNS = Application.GetNamespace("MAPI")
    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
    Set objFolder = objInbox.Folders(FolderName)

'Assume this is a mail folder
    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.Move objFolder
            End If
        End If
    Next

    For Each objPost In Application.ActiveExplorer.Selection
                objPost.Move objFolder
    Next

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

Sub ForBlog()
    ' Categorize something as @Blog context
    ' and move it to the folder containing
    ' items I want to blog about
    SetCategory ("@Blog")
    MoveSelectedMessagesToFolder ("For Blog")
End Sub

Sub ForReading()
    ' Same concept as the prior macro
    ' Used for items I want to read at some
    ' point in the future, but otherwise need
    ' no action
    SetCategory ("@Read")
    MoveSelectedMessagesToFolder ("Reading")
End Sub

Sub ForReference()
    ' Still the same concept.  Used for a few items
    ' I want easily/quickly accessible without having
    ' to rely on WDS
    SetCategory ("zzReference")
    MoveSelectedMessagesToFolder ("Reference")
End Sub

Sub ForHomeFile()
    ' While I archive most of my emails, I do
    ' like the appearance of an empty inbox. Once
    ' I'm done with my initial processing of an email
    ' I just toss it into a general, uncategorized
    ' folder.  If I ever need it again, I can use
    ' WDS to find it
    MoveSelectedMessagesToFolder ("Filed-Home")
End Sub

Sub ForWorkFile()
    ' Prior macro used on my home PC.  Have a slightly
    ' different name on the Exchange server at work.
    MoveSelectedMessagesToFolder ("Filed")
End Sub

Sub ForwardIt(MailRecipient As String)
    ' General macro called to forward the item by email
    ' to MailRecipient.  I learned the hard way that you
    ' have to be sure to clear the CC and BCC fields or
    ' you may be surprised....
    Set objApp = CreateObject("Outlook.Application")
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
            GetCurrentItem.To = MailRecipient
            GetCurrentItem.CC = ""
            GetCurrentItem.BCC = ""
            GetCurrentItem.Send
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
            GetCurrentItem.To = MailRecipient
            GetCurrentItem.CC = ""
            GetCurrentItem.BCC = ""
            GetCurrentItem.Send
        Case Else
            ' anything else will result in an error, which is
            ' why we have the error handler above
    End Select

    Set objApp = Nothing
End Sub

Sub SendForBlog()
    ' Outlook-able items I come across on my work machine
    ' that I want to blog about get sent to a special mailbox
    ' at home, rather than filed on the office Exchange server
    ' Mail filters will categorize it and move it into the
    ' correct folder at home upon receipt.
    ForwardIt ("my.for-blog.address@my.domain")
End Sub

Sub SendForRead()
    ' Same idea, with items I want to read sometime
    ForwardIt ("my.for-read.addess@my.domain")
End Sub

Sub SendForReference()
    ' Same idea, but for reference items
    ForwardIt ("my.for-reference.address@my.domain")
End Sub

Sub Calendar()
    ' This macro takes a mail/post/RSS item,
    ' allows you to (re)assign a category and create an appointment-like name
    ' for it, moves it into the calendar folder, and then opens the new
    ' appointment for further editing.  In other words, this approximates
    ' the functionality of dragging a mail item to the calendar icon in Outlook.

    ' Dim item As MailItem
        ' Commented out to "generalize the macro"
        ' Now it runs on PostItems and RssItems
    Dim myolApp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    'Dim fileFolder As Outlook.Folder
    Dim newName As String

    Select Case TypeName(Outlook.Application.ActiveWindow)
        Case "Explorer"
            Set item = Outlook.Application.ActiveExplorer.Selection.item(1)
        Case "Inspector"
            Set item = Outlook.Application.ActiveInspector.CurrentItem
        Case Else
            '
    End Select

    ' Mark as unread
    item.UnRead = False
    item.Save
    ' Pick the category
    item.ShowCategoriesDialog
    ' Rename it
    newName = InputBox("Please enter a subject for the calendar item:", _
          "Calendar Item Subject", item.Subject)
    item.Subject = newName
    item.Save
    ' Move it to the default calendar
    Set myolApp = CreateObject("Outlook.Application")
    Set myNamespace = myolApp.GetNamespace("MAPI")
    Set myTasks = myNamespace.GetDefaultFolder(olFolderCalendar)
    newItem = item.Move(myTasks)
    ' Find the new appointment, and open it
    Set myItems = myTasks.Items
    Set myItem = myItems.Find("[Subject] = '" + newName + "'")
    While TypeName(myItem) <> "Nothing"
        myItem.Display
        Set myItem = myItems.FindNext
    Wend
End Sub