GTD police (whkratz) with next steps (xoff) macro
Ok - I think I found the clean - GTD police (whkratz) with next steps (xoff) which goes in thisoutlooksession - error handlers and enable police are in goggle cache - see post by whkatz a few posts above
- try at your own risk (aka professional driver on closed course) watch for any lines which get word wrapped in this post - they usually show up in red in VBA
' Module : ThisOutlookSession
' Description:
' Procedures : Application_Startup()
' objTaskItems_ItemChange(ByVal pobjItem As Object)
' Modified :
' 11/13/03 GTDPolice code by Bill Kratz;
' 02/11/05 "Next Steps" to included handling of sequential actions by Xoff Poppe 2/11/05
' For Next Steps to work first action needs to be in subject line of the task.
' Following actions need to be in the Body of task each in its own line and preceded by "- " (dash space)
' --------------------------------------------------
Private WithEvents objTaskItems As Items
Private Sub Application_Startup()
'TVCodeTools ErrorEnablerStart
On Error GoTo PROC_ERR
'TVCodeTools ErrorEnablerEnd
Dim objNS As NameSpace
Set objNS = Application.GetNamespace("MAPI")
Set objTaskItems = objNS.GetDefaultFolder(olFolderTasks).Items
'TVCodeTools ErrorHandlerStart
PROC_EXIT:
Exit Sub
PROC_ERR:
Call LogError(Err.Number, Err.Description, "Application_Startup", Erl, "ThisOutlookSession")
Resume PROC_EXIT
'TVCodeTools ErrorHandlerEnd
End Sub
Private Sub objTaskItems_ItemChange(ByVal pobjItem As Object)
'TVCodeTools ErrorEnablerStart
10 On Error GoTo PROC_ERR
'TVCodeTools ErrorEnablerEnd
Dim objApp As Outlook.Application
Dim objNewTask As TaskItem
Dim intAns As Integer
Dim strSubject As String
Dim strProject As String
Dim objProperty As UserProperty
Dim strBody As String
Dim NewSubject As String
Dim NewBody As String
Dim PosCR As Integer
20 Set objApp = CreateObject("Outlook.Application")
30 If GetSetting(appname:="GTDPolice", section:="Settings", key:="Enable", Default:=0) = 1 Then
' Start NetCentrics Addin code
40 Set objProperty = pobjItem.UserProperties.Find("Project")
50 If Not objProperty Is Nothing Then
60 strSubject = pobjItem.Subject
70 strProject = pobjItem.UserProperties("Project")
75 strBody = pobjItem.Body
80 If Not pobjItem.UserProperties("Project") = "" Then
90 If pobjItem.Status = 2 Then
'Next Steps code starts here
95 If Left(strBody, 1) = "-" Then 'dash can be replaced for any other constant traile
100 Set objNewTask = objApp.CreateItem(olTaskItem)
110 With objNewTask
120 objNewTask.UserProperties.Add("Project", olText) = strProject 'Item.UserProperties("Project")
130 objNewTask.UserProperties.Add("GettingThingsDone", olYesNo) = 1
133 If InStr(strBody, vbCrLf) Empty Then
135 PosCR = InStr(strBody, vbCrLf) 'looks for position of carriage return
140 objNewTask.Subject = Mid(strBody, 3, (PosCR - 3)) 'third position in Mid removes "- "
150 objNewTask.Body = Right(strBody, ((Len(strBody) - PosCR) - 1))
155 Else
157 objNewTask.Subject = Right(strBody, ((Len(strBody) - 2))) 'number 2 removes "- "
160 End If
'objNewTask.Subject = "[" & Item.UserProperties("Project") & "]"
190 objNewTask.Display
200 End With
'Next Steps ends here
210 Else
220 intAns = MsgBox("You have completed a Project-related Task." & vbCrLf & "Task: " & strSubject & vbCrLf & "Project: " & strProject & vbCrLf & "Do you want to create a new Next Action for the Project?", 36, "Next Action?")
230 If intAns = 6 Then
240 Set objNewTask = objApp.CreateItem(olTaskItem)
250 With objNewTask
260 objNewTask.UserProperties.Add("Project", olText) = strProject 'Item.UserProperties("Project")
270 objNewTask.UserProperties.Add("GettingThingsDone", olYesNo) = 1
280 'objNewTask.Subject = "[" & Item.UserProperties("Project") & "]"
285 objNewTask.Display
290 End With
300 End If
310 End If
320 End If
330 End If
340 End If
350 End If
360 Set objApp = Nothing
370 Set objNewTask = Nothing
380 Set objProperty = Nothing
390 Set pobjItem = Nothing
'TVCodeTools ErrorHandlerStart
PROC_EXIT:
400 Exit Sub
PROC_ERR:
500 Call LogError(Err.Number, Err.Description, "objTaskItems_ItemChange", Erl, "ThisOutlookSession")
510 Resume PROC_EXIT
'TVCodeTools ErrorHandlerEnd
End Sub
