Thinking Rock 2.0 to Outlook Import Code – Provided as is and all disclaimers!

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, “&apos;”, “‘”)
        sTemp = Replace(sTemp, “&amp;”, “&”)
        sTemp = Replace(sTemp, “&#x0D;”, “”)
        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

Technorati Tags: ,,

2 thoughts on “Thinking Rock 2.0 to Outlook Import Code – Provided as is and all disclaimers!”

Leave a Reply

This site uses Akismet to reduce spam. Learn how your comment data is processed.