A commenter (Richard Brand) on an earlier post asked for the code I used to import only the active tasks into Outlook from the xml file. I do believe this is possibly the worst programming code ever written, but it works, mostly, for how I used it at any rate.
I should note though that when I do the import into Outlook, it regularly freezes my Blackberry Task list so that I have to do a hot boot (take out the battery) to reset it (it comes up with a java error).
Code provided as is, without warranty, use it at your own peril and, quite frankly, it probably won’t work for you :). But you may be desperate enough to try.
Note: you will need to put this into an Outlook VB code module, and link that to a button the toolbar (which you click to do the import). If you have no idea what I’m talking about, you probably shouldn’t be trying this. You will also need to provide the path to your TR file (“myFile” is the variable). All tasks imported from TR have the category “ZZZ Thinking Rock”. Projects are ignored (Outlook doesn’t want to know about them), but project tasks that are currently active are brought over. At the end of this process, all active tasks are imported into Outlook.
Dim m_booFutureFlag As Boolean
Sub tr()
‘ Import TR File into Outlook
Dim myItem As TaskItem
Dim myNote As NoteItem
Dim myFile, sWork As String
Dim sFile As String
Dim sTemp As String
Dim sRecord As String
Dim sContext(50) As String
Dim sContextSort(50) As String
Dim sTask(500, 3) As String
Dim sTaskSort(500, 3) As String
Dim iRecord As Long
Dim iCurrent As Long
Dim iCounter As Long
Dim i As Integer
‘ Clear out current tasks
‘Dim myNamespace As Outlook.NameSpace
‘Dim myTasks As Outlook.Items
‘Dim myObject As Object
‘
‘ Set myNamespace = Application.GetNamespace(“MAPI”)
‘ Set myTasks = myNamespace.GetDefaultFolder(olFolderTasks).Items
‘
‘ For Each myObject In myTasks
‘ If (myObject.Class = olTask) Then
‘ If InStr(myObject.Categories, “ZZZ Thinking Rock”) <> 0 Then
‘ myObject.Delete
‘ End If
‘ End If
‘ Next
myFile = “C:UsersmaxelsenDocumentsTasksthinkingrock.trx”
Open myFile For Input As #1
Line Input #1, sFile
‘ Get context information
iStart = InStr(sFile, “<contexts>”)
If iStart = 0 Then
iStart = 1
End If
m_booFutureFlag = False
iEnd = InStr(iStart, sFile, “</contexts>”)
sRecord = Mid(sFile, iStart, iEnd – iStart)
For i = 1 To 20
sContext(i) = Mid(sRecord, InStr(sRecord, “<context><name>”) + Len(“<context><name>”), InStr(sRecord, “</name>”) – InStr(sRecord, “<context><name>”) – Len(“<context><name>”))
sRecord = Mid(sRecord, InStr(sRecord, “</name>”) + Len(“</name>”), Len(sRecord))
If InStr(sRecord, “</name>”) = 0 Then
i = 1500
End If
Next i
For i = 1 To 20
For j = 1 To 20
If (sContext(i) < sContextSort(j) Or sContextSort(j) = “”) And sContext(i) <> “” Then
For k = 20 To j Step -1
sContextSort(k + 1) = sContextSort(k)
Next k
sContextSort(j) = sContext(i)
Exit For
End If
Next j
Next i
For i = 1 To 20
sContext(i) = sContextSort(i)
Next i
iRecord = 1
iCounter = 0
While Len(sFile) > 0 And iRecord < 50000
sRecord = GetNextAction(sFile)
iRecord = iRecord + 1
‘ Debug.Print iRecord
‘ Set myItem = Application.CreateItem(olTaskItem)
If IsAction(sRecord) = True Then
If ToDo(sRecord) = True Then
sTask(iCounter, 1) = GetNode(“description”, sRecord)
‘ myItem.Subject = GetNode(“description”, sRecord)
‘myItem.Body = GetNode(“notes”, sRecord)
‘ myItem.CreationTime = GetNode(“ceated”, sRecord)
i = GetValue(“context reference”, sRecord)
If i > 140 Then
i = i – 141
End If
If i > 20 Then
i = 0
End If
sTask(iCounter, 2) = sContext(i)
‘ myItem.Categories = sContext(i) + “,ZZZ Thinking Rock”
‘ myItem.Complete = GetNode(“done”, sRecord)
If InStr(sRecord, “<date>”) <> 0 Then
‘ myItem.DueDate = CDate(Left(GetNode(“date”, sRecord), 10) + ” 23:30″)
sTask(iCounter, 3) = CStr(Left(GetNode(“date”, sRecord), 10))
End If
iCounter = iCounter + 1
‘myItem.Save
End If
End If
sFile = MoveNext(sFile)
Wend
Close #1
iCurrent = 1
For i = 1 To iCounter
If sTask(i, 2) = “” Then
sTask(i, 2) = “None”
End If
Next i
For i = 1 To 20
For j = 1 To iCounter
If sTask(j, 2) = sContext(i) Then
sTaskSort(iCurrent, 1) = sTask(j, 1)
sTaskSort(iCurrent, 2) = sTask(j, 2)
sTaskSort(iCurrent, 3) = sTask(j, 3)
iCurrent = iCurrent + 1
End If
Next j
Next i
For i = 1 To iCounter
sTask(i, 1) = sTaskSort(i, 1)
sTask(i, 2) = sTaskSort(i, 2)
sTask(i, 3) = sTaskSort(i, 3)
Next i
Set myNote = Application.CreateItem(olNoteItem)
myNote.Body = “To Do List ” + Format$(CStr((Now())), “dd/mm/yyyy”) + Chr$(13) + Chr$(10)
For i = 1 To iCounter
If sTask(i, 2) <> sTask(i – 1, 2) Or i = 1 Then
myNote.Body = myNote.Body + Chr$(13) + Chr$(10) + “@” + sTask(i, 2) + Chr$(13) + Chr$(10)
myNote.Body = myNote.Body + String(Len(“@” + sTask(i, 2)), “-“) + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)
End If
myNote.Body = myNote.Body + sTask(i, 1)
If sTask(i, 3) <> “” Then
myNote.Body = myNote.Body + ” – Due by: ” + sTask(i, 3) + Chr$(13) + Chr$(10)
End If
Next i
myNote.Save
End
End Sub
Public Function GetNextAction(ByVal sFile As String)
Dim sRecord As String
Dim sTemp As String
Dim iStart As Long
Dim iEnd As Long
iStart = InStr(sFile, “<action>”)
If iStart = 0 Then
iStart = 1
End If
iEnd = InStr(iStart, sFile, “</action>”)
If iEnd <> 0 Then
sTemp = Mid(sFile, iStart, iEnd – iStart)
sTemp = Replace(sTemp, “'”, “‘”)
sTemp = Replace(sTemp, “&”, “&”)
sTemp = Replace(sTemp, “
”, “”)
If InStr(sTemp, “</thought>”) <> 0 Then
sTemp = Replace(Left(sTemp, InStr(sTemp, “</thought>”)), “<description>”, “<thought_description>”) + Mid(sTemp, InStr(sTemp, “</thought>”) + 1, Len(sTemp))
sTemp = Replace(Left(sTemp, InStr(sTemp, “</thought>”)), “</description>”, “</thought_description>”) + Mid(sTemp, InStr(sTemp, “</thought>”) + 1, Len(sTemp))
End If
If InStr(Left(sFile, iStart), “tr.model.project.ProjectTemplates”) <> 0 And m_booFutureFlag = False Then
m_booFutureFlag = True
End If
If InStr(Left(sFile, iStart), “</rootTemplates>”) <> 0 And m_booFutureFlag = True Then
m_booFutureFlag = False
End If
Else
sTemp = “”
End If
sRecord = sTemp
GetNextAction = sRecord
End Function
Public Function GetNode(sType As String, sRecord As String)
Dim sValue As String
If InStr(sRecord, “<” + sType + “>”) <> 0 And InStr(sRecord, “</” + sType + “>”) <> 0 Then
sValue = Mid(sRecord, InStr(sRecord, “<” + sType + “>”) + Len(“<” + sType + “>”), InStr(sRecord, “</” + sType + “>”) – InStr(sRecord, “<” + sType + “>”) – Len(“<” + sType + “>”))
Else
sValue = “”
End If
GetNode = sValue
End Function
Public Function MoveNext(sFile As String)
If InStr(sFile, “<action>”) <> 0 Then
sFile = Mid(sFile, InStr(sFile, “</action”) + Len(“</action>”), Len(sFile))
Else
sFile = “”
End If
MoveNext = sFile
End Function
Public Function IsAction(sRecord As String) As Boolean
If m_booFutureFlag = True Then
IsAction = False
ElseIf InStr(sRecord, “Bio and contact”) <> 0 Then
‘ElseIf InStr(sRecord, “parent class=” + Chr$(34)) <> 0 And InStr(sRecord, “tr.model.project.ProjectTemplates”) = 0 Then
IsAction = False
ElseIf InStr(sRecord, “parent class=” + Chr$(34) + “actions” + Chr$(34)) <> 0 Then
IsAction = True
ElseIf InStr(sRecord, “parent reference=” + Chr$(34)) <> 0 And InStr(sRecord, “/futures/items/future”) = 0 Then
IsAction = True
Else
IsAction = False
End If
End Function
Public Function GetValue(sType As String, sRecord As String) As Integer
Dim sTemp As String
Dim iReturn As String
Dim iStart, iEnd As Long
iStart = InStr(sRecord, “<” + sType + “=”) + Len(“<” + sType + “=”)
iEnd = InStr(iStart, sRecord, “/>”)
sTemp = Mid(sRecord, iStart, iEnd – iStart)
If InStr(sTemp, “[“) <> 0 Then
sTemp = Mid(sTemp, InStr(sTemp, “[“) + 1, InStr(sTemp, “]”) – InStr(sTemp, “[“) – 1)
iReturn = CInt(sTemp)
Else
iReturn = 0
End If
GetValue = iReturn
End Function
Public Function GetSetting(sType As String, sRecord As String) As String
Dim sTemp As String
Dim iReturn As String
Dim iStart, iEnd As Long
iStart = InStr(sRecord, “<” + sType + “=”) + Len(“<” + sType + “=”)
iEnd = InStr(iStart, sRecord, “>”)
sTemp = Replace(Mid(sRecord, iStart, iEnd – iStart), Chr$(34), “”)
GetSetting = sTemp
End Function
Public Function ToDo(sRecord As String) As Boolean
Dim sWork, sTemp As String
Dim i, j, k As Integer
Dim booToDo As Boolean
Dim datToDo As Date
booToDo = False
If GetNode(“done”, sRecord) = False Then
If InStr(sRecord, “<date>”) <> 0 Then
If GetSetting(“state class”, sRecord) = “actionStateScheduled” Then
datToDo = CDate(Left(GetNode(“date”, sRecord), 10) + ” 23:30″)
If datToDo < CDate(Left(CStr(Now()), 10) + ” 23:45″) Then
booToDo = True
End If
End If
End If
If GetSetting(“state class”, sRecord) = “actionStateASAP” Then
booToDo = True
End If
End If
ToDo = booToDo
End Function
Sub Task()
Dim item As MailItem
Set item = Outlook.Application.ActiveExplorer.Selection.item(1)
item.ShowCategoriesDialog
Dim myolApp As Outlook.Application
Dim myNamespace As Outlook.NameSpace
Dim myTasks As Outlook.Folder
Dim myFolder As Outlook.Folder
Set myolApp = CreateObject(“Outlook.Application”)
Set myNamespace = myolApp.GetNamespace(“MAPI”)
Set myTasks = myNamespace.GetDefaultFolder(olFolderTasks)
item.Copy
item.Move myTasks
End Sub
Sub File()
MoveToFolder.Show (1)
End Sub
Sub FileOld()
Dim item As MailItem
Dim myolApp As Outlook.Application
Dim myNamespace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim rootFolder As Outlook.Folder
Dim subFolders As Outlook.fOLDERS
Dim subFolder As Outlook.Folder
Dim fileFolder As Outlook.Folder
Dim fileEntryID As String
Dim FileFolderName As String
‘Set the folder name – must be at the same level as the inbox
FileFolderName = “Filing Cabinet”
‘ Pick the category
Set item = Outlook.Application.ActiveExplorer.Selection.item(1)
item.ShowCategoriesDialog
‘ Move the the file folder
Set myolApp = CreateObject(“Outlook.Application”)
Set myNamespace = myolApp.GetNamespace(“MAPI”)
Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
Set rootFolder = myInbox.Parent
Set subFolders = rootFolder.fOLDERS
Set subFolder = subFolders.GetFirst
Do While Not subFolder Is Nothing
If subFolder.Name = FileFolderName Then
fileEntryID = subFolder.EntryID
Set fileFolder = myNamespace.GetFolderFromID(fileEntryID)
item.Move fileFolder
Exit Do
End If
Set subFolder = subFolders.GetNext
Loop
End Sub
Sub ClearTR()
‘ Import TR File into Outlook
Dim myItem As TaskItem
Dim myFile, sWork As String
Dim sFile As String
Dim sTemp As String
Dim sRecord As String
Dim sContext(50) As String
Dim iRecord As Long
Dim i As Integer
‘ Clear out current tasks
Dim myNamespace As Outlook.NameSpace
Dim myTasks As Outlook.Items
Dim myObject As Object
Set myNamespace = Application.GetNamespace(“MAPI”)
Set myTasks = myNamespace.GetDefaultFolder(olFolderTasks).Items
For Each myObject In myTasks
If (myObject.Class = olTask) Then
If InStr(myObject.Categories, “ZZZ Thinking Rock”) <> 0 Then
myObject.Delete
End If
End If
Next
End Sub
Sub ClearTRCat()
‘ Clear out current tasks
Dim myNamespace As Outlook.NameSpace
Dim myTasks As Outlook.Items
Dim myObject As Object
Set myNamespace = Application.GetNamespace(“MAPI”)
Set myTasks = myNamespace.GetDefaultFolder(olFolderTasks).Items
For Each myObject In myTasks
If (myObject.Class = olTask) Then
If InStr(myObject.Categories, “ZZZ Thinking Rock”) <> 0 Then
myObject.Categories = Replace(myObject.Categories, “ZZZ Thinking Rock”, “”)
myObject.Save
End If
End If
Next
End Sub
Sub FlagToDo()
‘ Import TR File into Outlook
Dim myItem As TaskItem
Dim myFile, sWork As String
Dim sFile As String
Dim sTemp As String
Dim sRecord As String
Dim sContext(50) As String
Dim iRecord As Long
Dim i As Integer
‘ Clear out current tasks
Dim myNamespace As Outlook.NameSpace
Dim myTasks As Outlook.Items
Dim myObject As Object
Set myNamespace = Application.GetNamespace(“MAPI”)
Set myTasks = myNamespace.GetDefaultFolder(olFolderToDo).Items
For Each myObject In myTasks
If (myObject.Class = olTask) Then
myObject.Categories = Replace(myObject.Categories, “@DoToday”, “”)
If (myObject.DueDate <= Now() Or myObject.DueDate = “1/01/4501”) And myObject.Complete = False Then
myObject.Categories = Replace(“@DoToday ” + myObject.Categories, “,”, “, @DoToday”) + “,@DoToday”
End If
myObject.Save
End If
Next
End Sub
Thank you for posting this – most appreciated, and very slack of me to take over 6 months to notice!
@Richard – Thanks, as I say it’s probably only a pointer. Don’t know that it really works properly, suspect it doesn’t.