Ao basecamp import.mmbas

Option Explicit Public use_colors As Boolean Sub Main 'ao_basecamp_import 29Sep07 -5 http://creativecommons.org/licenses/by-sa/2.5/ http://www.activityowner.com 'Program looks for basecamp.xml file in the "My Maps" directory and exports into basecamp0000.mmap '   Dim filename As String 		 'filename of nactionr xml file Dim outputfilename As String 'filename for nactionr.mmap output file Dim indoc As Document		 'basecame import xml map Dim outdoc As Document		 'mindmanager export project map Dim ctopic As Topic         'mindmanager centraltopic Dim itopic As Topic	 		 'MindManager Intray branch Dim ptopic As Topic			 'MindManager Project branch Dim companytopic As Topic	 'mindmanager company branch topic Dim prtopic As Topic        'mindManager project Dim rtopic As Topic			 'Resources branch Dim m As Topic				 'basecamp file main topics Dim p As Topic				 'basecamp project topic Dim t As Topic				 'basecamp main topics '	use_colors=True filename		=GetPath(mmDirectoryMyMaps) & "basecamp.xml" outputfilename	=GetPath(mmDirectoryMyMaps) & "basecamp-import0000.mmap" '	Set indoc	= Documents.Open(filename,"",True) 	'open basecamp xml file Set outdoc	= createfile(outputfilename)				'create output map if needed outdoc.Activate Set ctopic 	= outdoc.CentralTopic ctopic.Text=getattribute(indoc.CentralTopic,"name") & " basecamp import" '	Set itopic=createtopic(ctopic,"in-tray")			'add intray branch Set ptopic=createtopic(ctopic,"Projects") 			'add project branch Set rtopic=createtopic(ctopic,"Resources")			'add resources branch itopic.Task.Categories="In-tray*,process" '	listpeople rtopic,indoc								'add resources found in basecamp file '	Set t=gettopic(indoc.CentralTopic,"projects") For Each p In t.AllSubTopics If p.Text="project" Then Set companytopic=createtopic(ptopic,getattribute(gettopic(p,"company"),"name")) Set prtopic = createtopic(companytopic,getattribute(p,"name")) AddProjectIcon prtopic 'Add resultsmanager projecticon if resulstmanager is installed If getattribute(p,"status")="on_hold" Then prtopic.Icons.AddStockIcon(mmStockIconHourglass) prtopic.Task.Complete=0 addtasks prtopic, p,indoc 'loop through task under basecamp p branch add add to mindmanager prtopic branch colorproject(prtopic) End If   Next '	indoc.Close outdoc.Save End Sub Sub colorproject(prtopic As Topic) 'default is no change 'red for overdue or predecessor overdue 'yellow for upcoming deadlines 'green for complete Dim sp As Topic Dim isgreen As Boolean Dim isyellow As Boolean Dim isred As Boolean If use_colors Then isyellow=False isgreen=False isred=False If prtopic.Task.Complete=100 Then isgreen=True ElseIf prtopic.Task.DueDate>0 Then If prtopic.Task.DueDate0 Then If sp.Task.Complete<100 Then If sp.Task.DueDate<Date Then isred=True Else isyellow=True End If				End If			End If		Next If isred Then prtopic.FillColor.SetARGB(255,255,0,0) ElseIf isyellow Then prtopic.FillColor.SetARGB(255,255,255,0) ElseIf isgreen Then prtopic.FillColor.SetARGB(255,0,255,0) End If	End If End Sub

Function getattribute(t As Topic, a As String) As String 'get value for attribute a below topic t 	Dim s As Topic For Each s In t.AllSubTopics If s.Text=a Then getattribute=s.AllSubTopics(1).Text Next End Function Function getattribute2(t As Topic, a As String) As String 'get value for attribute a below topic t in 2nd format Dim s As Topic For Each s In t.AllSubTopics If s.Text=a Then getattribute2=s.AllSubTopics(2).Text Next End Function Function gettopic(t As Topic, a As String) As Topic 'get topic a attribute of topic t	Dim s As Topic Dim found As Boolean found=False For Each s In t.AllSubTopics If s.Text=a Then Set gettopic= s			found=True End If	Next If Not found Then MsgBox("error: " & a & " not found") End End If End Function Function hasattribute(t As Topic, a As String) As Boolean 'true if attribute a exists below topic t 	Dim s As Topic hasattribute=False For Each s In t.AllSubTopics If s.Text=a And s.AllSubTopics.Count>0 Then hasattribute=True Next End Function Function hasattribute2(t As Topic, a As String) As Boolean 'true if attribute a exists below topic t and has something in its 2nd field 'This was needed for milestone-id field Dim s As Topic hasattribute2=False For Each s In t.AllSubTopics If s.Text=a Then If s.AllSubTopics.Count=2 Then hasattribute2=True End If		End If	Next End Function Sub addtasks(ptopic As Topic, p As Topic,indoc As Document) 'add tasks under mindmanager ptopic project from basecamp p project branch Dim tlists As Topic Dim tlist As Topic Dim titems As Topic Dim titem As Topic Dim ttopic As Topic If hasattribute(p,"milestones") Then Set tlists = gettopic(p,"milestones") For Each tlist In tlists.AllSubTopics If tlist.Text="milestone" Then Set ttopic=addmilestone(ptopic, tlist, indoc) colorproject(ttopic) End If		Next End If	If hasattribute(p,"todo-lists") Then Set tlists = gettopic(p,"todo-lists") For Each tlist In tlists.AllSubTopics If tlist.Text="todo-list" Then If hasattribute2(tlist,"milestone-id") Then If Not getattribute2(tlist,"milestone-id")="0" Then Set ttopic=gettopic(ptopic,findmilestone(p,getattribute2(tlist,"milestone-id"))) Else Set ttopic=createtopic(ptopic,getattribute(tlist,"name")) ttopic.Task.Complete=getcomplete(tlist) AddResultIcon ttopic colorproject(ttopic) End If				Else Set ttopic=createtopic(ptopic,getattribute(tlist,"name")) ttopic.Task.Complete=getcomplete(tlist) AddResultIcon ttopic colorproject(ttopic) End If

Set titems = gettopic(tlist,"todo-items") For Each titem In titems.AllSubTopics If titem.Text="todo-item" Then addtask(ttopic,titem,indoc) Next End If		Next End If End Sub Function addmilestone(ptopic As Topic, tlist As Topic, indoc As Document) As Topic Set addmilestone=createtopic(ptopic,getattribute(tlist,"title")) addmilestone.Task.Resources = getperson(tlist, indoc) addmilestone.Task.DueDate = DateValue(getattribute2(tlist,"deadline")) addmilestone.Task.Complete = getcomplete(tlist) AddResultIcon addmilestone End Function Function findmilestone(p As Topic, id As String) As String Dim t As Topic Dim m As Topic Set m=gettopic(p,"milestones") For Each t In m.AllSubTopics If t.Text="milestone" Then If getattribute2(t,"id")=id Then findmilestone=getattribute(t,"title") End If	End If Next End Function

Function addtask(p As Topic, t As Topic, indoc As Document) 'add basecamp n task to mindmanager project p add set completion and resources Dim n As Topic Set n=createtopic(p,getattribute(t,"content")) n.Task.Complete = getcomplete(t) n.Task.Resources=getperson(t, indoc) End Function Function createtopic(parent As Topic,stext As String) 'find a topic or create it if doesn't exist Dim stopic As Topic Dim found As Boolean found=False For Each stopic In parent.AllSubTopics If stopic.Text=stext Then found=True Set createtopic=stopic End If	Next If Not found Then If parent.IsCentralTopic Then Set createtopic = parent.AddBalancedSubTopic(stext) Else Set createtopic = parent.AddSubTopic(stext) End If	End If End Function Function createfile(nfilename As String) As Document 'create a file if it doesn't exist already On Error GoTo X	Set createfile=Documents.Open(nfilename) If Err.Number>0 Then X:Set createfile=Documents.Add createfile.SaveAs(nfilename) Err.Clear End If	On Error GoTo 0 End Function Function getperson(t As Topic, indoc As Document) As String 'get the first name - last name associated with task Dim id As String Dim s As Topic Dim ss As Topic id=getattribute2(t,"responsible-party-id") Set s=gettopic(indoc.CentralTopic,"firm") Set s=gettopic(s,"people") For Each ss In s.AllSubTopics If ss.Text="person" Then If getattribute2(ss,"id")=id Then getperson=getattribute(ss,"first-name") & " " & getattribute(ss,"last-name") End If	 End If	Next End Function Sub listpeople(resourcetopic As Topic, indoc As Document) 'list people in basecamp file in mindmanager resource branch Dim s As Topic Dim t As Topic Dim p As Topic Dim r As Topic Dim ss As Topic Set s=gettopic(indoc.CentralTopic,"firm") Set r = createtopic(resourcetopic, getattribute(s,"name")) r.Icons.AddStockIcon(mmStockIconHouse) Set s=gettopic(s,"people") For Each t In s.AllSubTopics addperson r,t Next Set s = gettopic(indoc.CentralTopic,"clients") For Each ss In s.AllSubTopics If ss.Text="client" Then Set r=createtopic(resourcetopic,getattribute(ss,"name")) r.Icons.AddStockIcon(mmStockIconHouse) Set s=gettopic(ss,"people") For Each t In s.AllSubTopics addperson r,t Next End If	Next End Sub Sub addperson(parent As Topic, person As Topic) Dim p As Topic If person.Text="person" Then Set p = createtopic(parent,getattribute(person,"first-name") & " " & getattribute(person,"last-name")) p.Icons.AddStockIcon(mmStockIconResource1) If hasattribute(person,"email-address") Then p.CreateHyperlink("mailto:" & getattribute(person,"email-address")) End If		End If End Sub

Sub AddProjectIcon(t As Topic) On Error Resume Next t.Icons.AddCustomIcon("C:\Program Files\Gyronix\GyroQ\resultmanager-projecticon.ico") On Error GoTo 0 End Sub Sub AddResultIcon(t As Topic) On Error Resume Next t.Icons.AddCustomIcon("C:\Program Files\Gyronix\GyroQ\resultmanager-resulticon.ico") On Error GoTo 0 End Sub Function getcomplete(t As Topic) As Integer ' If hasattribute(t,"complete") Then If getattribute(t,"complete")="false" Then getcomplete=0 Else getcomplete=100 End If ElseIf hasattribute2(t,"completed") Then If getattribute2(t,"completed")="false" Then getcomplete=0 Else getcomplete=100 End If Else getcomplete=0 End If End Function