Attribute VB_Name = "LeanGTD2007" ' Lean GTD macros for Outlook 2007 ' Version: 2010-06-19 ' By Thomas Drakengren http://thomas.drakengren.com ' Downloaded from http://blog.drakengren.com/lean-gtd-2007/ ' User manual: ' Installation ' ------------ ' 1. Start the Outlook VB macro editor, and import this file. ' 2. Run the macro function “SetupLeanGTD2007”. This will install a toolbar with four useful buttons and ' remove any previous version of the toolbar, back to the version from 2009-08-28. ' 3. Make sure that unsigned macros aren't completely disabled (check under Tools -> Macros) ' 4. Installation is complete! ' Usage Instructions ' ------------------ ' The macro package installs four buttons on the toolbar. One for “Next Action”, which creates a task, ' and immediately prompts you for categories (where you have to add all your different kinds of actions), ' unless you’re positioned on another task. Then you’ll inherit all categories from it. The “@Waiting For” ' category is treated specially; there you’ll get a prefix with name and date for free. Also, you'll store ' the new task in the same folder as the task you're standing on. ' One button is “Act on Item”. That one creates a task, attaches the item (for example an email) to it, and prompts you for ' categories. It cleans up the title (removes “Re:”), too. And for “@Waiting For” tasks, it adds the ' recipient and the date to the task name, like for the task. ' One button is “Schedule Item”. It creates an appointment, and attaches the selected item to it. ' The last button is "All Day", which creates an all day action without a reminder. You can use it for entering ' info that applies to a certain day. See David Allen's writings for more info on suggested use, or find out ' for yourself! ' None of the buttons do anything about the item; you have to file it yourself, wherever you like. ' For me, that’s an advantage, since often I’d like to create perhaps two actions from a mail. ' Don’t forget to add a rule so that all your sent mail gets into your inbox, too, so that you can ' easily make actions from these, too. ' Change log ' ---------- ' 2006-12-07: First working version ' 2006-12-07: Added better error handling. ' 2008-08-19: Added support for tasks with multiple categories. ' 2009-06-13: “Companies” is copied from the selected task, just like the categories. ' 2009-08-15: Tasks are created in the same folder as the task you're standing on (if applicable) ' Renaming of variables to remove those "my" prefiges. They aren't mine anymore. ;-) ' 2009-08-16: Added header info to tasks and appointments based on emails. ' 2009-08-20: Possible to create tasks even if a task is selected, and the to-do-folder is selected. ' User manual added to source code file. ' Some last minute fixes and improvements. ' 2009-08-21: Better task subjects for "waiting for" tasks. You don't need to wait for yourself. ' 2009-08-22: Version check so that you don't try to run it on anything else than Outlook 2007. ' 2009-08-28: Act on Mail and Schedule Mail are generalized to work on any Outlook items. Some code cleanup. ' 2009-09-08: Added an "All Day" button for scheduling all day events (info for a certain day) pretty painlessly. ' 2009-09-08b: The "All Day" button copies start and end date from the selected appointment, alternatively ' from the first day in the current view if there's no selected appointment. ' 2009-09-08c: Improved error handling. There were errors if the Personal Folders view was shown. ' 2009-09-13: Changed some conflicting keyboard shortcuts ' 2010-06-19: Added comments for lines to remove in order to make the macros work with Outlook 2010. Const WaitingForText As String = "@Waiting For" ' Button texts. Change where the amphersand is placed if that would suit your language ' version of Outlook better. Const NextActionButtonText As String = "Ne&xt Action" Const ActOnItemButtonText As String = "Act on &Item" Const ScheduleItemButtonText As String = "S&chedule Item" Const ScheduleAllDayButtonText As String = "Al&l Day" Const CommandBarName As String = "Lean GTD for Outlook 2007" ' --- First, we need some auxiliary functions. --- ' Convert an item to a text representation including headers Private Function GetItemAsText(item As Object) Dim fromLine As String Dim sendLine As String Dim toLine As String Dim subjectLine As String Dim ItemBody As String ' Errors can just be skipped here. On Error Resume Next fromLine = "" fromLine = "From: " + vbTab + item.SenderName + " [" + item.SenderEmailAddress + "]" + vbCrLf sentLine = "" sentLine = "Sent: " + vbTab + Format(item.SentOn) + vbCrLf toLine = "" toLine = "To: " + vbTab + item.To + vbCrLf subjectLine = "" subjectLine = "Subject: " + vbTab + item.subject + vbCrLf ItemBody = "" ItemBody = item.body ' Re-enable errors On Error GoTo 0 GetItemAsText = fromLine + sentLine + toLine + subjectLine + "----------" + vbCrLf + ItemBody End Function Private Function ExplorerHasSelectedItems() On Error GoTo NoSelection ExplorerHasSelectedItems = (Outlook.Application.ActiveExplorer.Selection.Count > 0) Exit Function NoSelection: ExplorerHasSelectedItems = False End Function Private Function GetSubjectFromItem(item As Object) Dim subject As String subject = "" ' Maybe not all items' got a subject On Error GoTo NoSubject subject = item.subject On Error GoTo 0 subject = Replace(subject, "RE: ", "") subject = Replace(subject, "Re: ", "") GetSubjectFromItem = subject Exit Function NoSubject: GetSubjectFromItem = "" End Function ' Gets name and date from item Private Function GetWaitingForPrefix(currentNameSpace As Outlook.NameSpace, item As Object) Dim whomToWaitFor As String ' If nothing else works whomToWaitFor = "" ' Just skip undefined values On Error Resume Next ' Don't wait for myself. If item.SenderName = currentNameSpace.CurrentUser.Name Then ' If I sent the item, then wait for the recipient whomToWaitFor = item.To ElseIf Len(item.SenderName) = 0 Then ' No sender name; take the email adress whomToWaitFor = item.SenderEmailAddress Else ' Just take the name if there is one. whomToWaitFor = item.SenderName End If ' Re-enable errors On Error GoTo 0 NoSender: Dim receivedTime As Date ' Current time is default receivedTime = Date On Error Resume Next receivedTime = item.receivedTime ' Back again On Error GoTo 0 GetWaitingForPrefix = whomToWaitFor + " " + CStr(DateSerial(Year(receivedTime), Month(receivedTime), Day(receivedTime))) End Function Private Function CalendarViewIsActive() On Error GoTo NoView: CalendarViewIsActive = (TypeOf Outlook.Application.ActiveExplorer.CurrentView Is CalendarView) Exit Function NoView: CalendarViewIsActive = False End Function ' --- Here comes the main macro functions. ---- Sub CreateNextAction() Dim taskCategories As String Dim taskCompanies As String Dim tasksFolder As Outlook.Folder Dim toDoFolder As Outlook.Folder Dim defaultFolder As Outlook.Folder Dim currentTaskItem As Outlook.TaskItem taskCategories = "" taskCompanies = "" Dim currentOlApp As Outlook.Application Dim currentNameSpace As Outlook.NameSpace Set currentOlApp = CreateObject("Outlook.Application") Set currentNameSpace = currentOlApp.GetNamespace("MAPI") ' We don't want to create tasks in this one, because it's impossible. Set toDoFolder = currentNameSpace.GetDefaultFolder(olFolderToDo) ' This is the default folder for tasks. Set defaultFolder = currentNameSpace.GetDefaultFolder(olFolderTasks) ' In what folder will we put the task? Set tasksFolder = Outlook.Application.ActiveExplorer.CurrentFolder ' But is has to be a task folder. If tasksFolder.DefaultItemType <> olTaskItem Then Set tasksFolder = defaultFolder ' We can't create tasks in the To Do folder, so then we'll use the default folder ElseIf tasksFolder = toDoFolder Then Set tasksFolder = defaultFolder End If ' Can we get the categories and companies from a selected task? If ExplorerHasSelectedItems() Then If (TypeOf Outlook.Application.ActiveExplorer.Selection.item(1) Is TaskItem) Then Set currentTaskItem = Outlook.Application.ActiveExplorer.Selection.item(1) taskCategories = currentTaskItem.Categories taskCompanies = currentTaskItem.Companies End If End If Dim newTask As Outlook.TaskItem Dim subject As String ' Create a task in the right folder Set newTask = tasksFolder.Items.Add(olTaskItem) ' Transfer categories and companies newTask.Categories = taskCategories newTask.Companies = taskCompanies newTask.Display If taskCategories = "" Then newTask.ShowCategoriesDialog End If ' Special treatment for waiting for actions If InStr(newTask.Categories, WaitingForText) Then ' Add name and date to subject subject = newTask.subject newTask.subject = " " + CStr(Date) + ": " + subject End If End Sub Sub ActOnItem() Dim newTask As Outlook.TaskItem Dim currentOlApp As Outlook.Application Dim currentNameSpace As Outlook.NameSpace ' Set up context Set currentOlApp = CreateObject("Outlook.Application") Set currentNameSpace = currentOlApp.GetNamespace("MAPI") ' Something needs to be selected If ExplorerHasSelectedItems() Then Dim selectedItem As Object Set selectedItem = Outlook.Application.ActiveExplorer.Selection.item(1) Set newTask = currentOlApp.CreateItem(olTaskItem) newTask.subject = GetSubjectFromItem(selectedItem) newTask.body = GetItemAsText(selectedItem) ' Add the item as an attachment ' Remove for Outlook 2010. newTask.Attachments.Add selectedItem ' Now we can do the task editing. newTask.Display newTask.ShowCategoriesDialog ' Special treatment for waiting for actions If InStr(newTask.Categories, WaitingForText) Then ' Add a prefix for @Waiting For tasks newTask.subject = GetWaitingForPrefix(currentNameSpace, selectedItem) + ": " + newTask.subject End If End If End Sub Sub ScheduleItem() Dim currentOlApp As Outlook.Application Dim currentNameSpace As Outlook.NameSpace ' Set up context Set currentOlApp = CreateObject("Outlook.Application") Set currentNameSpace = currentOlApp.GetNamespace("MAPI") Dim newAppointment As Outlook.AppointmentItem Dim selectedItem As Object ' There might be no selection If ExplorerHasSelectedItems() Then Set selectedItem = Outlook.Application.ActiveExplorer.Selection.item(1) Set newAppointment = currentOlApp.CreateItem(olAppointmentItem) ' Get item info from appointment newAppointment.subject = GetSubjectFromItem(selectedItem) newAppointment.body = GetItemAsText(selectedItem) ' Add the item as an attachment ' Remove for Outlook 2010. newAppointment.Attachments.Add selectedItem ' Now we can do the appointment editing. newAppointment.Display Dim result As VbMsgBoxResult result = MsgBox("Will this be an all day event?", vbYesNo, "All day?") If result = vbYes Then newAppointment.AllDayEvent = True ' All day events shouldn't have a reminder newAppointment.ReminderSet = False End If End If End Sub Sub ScheduleAllDay() Dim currentOlApp As Outlook.Application Dim currentNameSpace As Outlook.NameSpace ' Set up context Set currentOlApp = CreateObject("Outlook.Application") Dim newAppointment As Outlook.AppointmentItem Set newAppointment = currentOlApp.CreateItem(olAppointmentItem) ' Now we can do the appointment editing. newAppointment.Display ' An all day event newAppointment.AllDayEvent = True ' All day events shouldn't have a reminder newAppointment.ReminderSet = False ' Get the date from another appointment If ExplorerHasSelectedItems() Then Dim selectedItem As Object Set selectedItem = Outlook.Application.ActiveExplorer.Selection.item(1) ' Only inherit from appointments If TypeOf selectedItem Is AppointmentItem Then newAppointment.Start = DateValue(selectedItem.Start) ' Strange thing with dates; don't know exactly why newAppointment.End = newAppointment.Start + 1 End If ' Or from the current date ElseIf CalendarViewIsActive() Then Dim view As CalendarView Set view = Outlook.Application.ActiveExplorer.CurrentView Dim dates As Variant dates = view.DisplayedDates ' Be safe and check that it is an array If IsArray(dates) Then Dim size As Integer ' Size of array size = UBound(dates) - LBound(dates) + 1 ' At least one date must be shown If size > 0 Then Dim appointmentDate As Date ' Pick the first one shown in the view appointmentDate = DateValue(dates(LBound(dates))) ' Set start and end from the picked date newAppointment.Start = appointmentDate ' Strange thing with dates; don't know exactly why newAppointment.End = appointmentDate + 1 End If End If End If End Sub Sub SetupLeanGTD2007() ' Check that you're using the right version of Outlook If Not (Outlook.Version Like "12.*") Then MsgBox "This macro package can only be used with Outlook 2007", vbOKOnly, "Error" End If Dim currentOlApp As Outlook.Application Dim olExp As Outlook.Explorer Dim objCB As CommandBar Set currentOlApp = CreateObject("Outlook.Application") Set olExp = currentOlApp.ActiveExplorer ' Delete the command bar if it exists On Error Resume Next olExp.CommandBars.item(CommandBarName).Delete ' Add the command bar Set objCB = olExp.CommandBars.Add(CommandBarName) objCB.Enabled = True objCB.Position = msoBarTop objCB.Visible = True ' Set up the buttons, references to macros, and shortcuts. Set objNA = objCB.Controls.Add(msoControlButton) objNA.Caption = NextActionButtonText objNA.FaceId = 7264 objNA.Style = msoButtonIconAndCaption objNA.OnAction = "CreateNextAction" objNA.BeginGroup = True objNA.TooltipText = "Create a Next Action" Set objNA = objCB.Controls.Add(msoControlButton) objNA.Caption = ActOnItemButtonText objNA.FaceId = 7264 objNA.Style = msoButtonIconAndCaption objNA.OnAction = "ActOnItem" objNA.BeginGroup = True objNA.TooltipText = "Create a Next Action for an Item" Set objNA = objCB.Controls.Add(msoControlButton) objNA.Caption = ScheduleItemButtonText objNA.FaceId = 1992 objNA.Style = msoButtonIconAndCaption objNA.OnAction = "ScheduleItem" objNA.BeginGroup = True objNA.TooltipText = "Schedule an Item in the Calendar" Set objNA = objCB.Controls.Add(msoControlButton) objNA.Caption = ScheduleAllDayButtonText objNA.FaceId = 1992 objNA.Style = msoButtonIconAndCaption objNA.OnAction = "ScheduleAllDay" objNA.BeginGroup = True objNA.TooltipText = "Schedule an All Day Event in the Calendar" ' Notify the user that everything went OK. MsgBox "Lean GTD 2007 macro package successfully installed.", vbOKOnly, "Installed" End Sub