Ao basecamp import.mmbas

From ActivityOwnerWiki
Jump to: navigation, search
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.DueDate<Date() Then
				isred = True
			Else
				isyellow=True
			End If
		End If
		For Each sp In prtopic.AllSubTopics
			If sp.Task.DueDate>0 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