Map2Excel.mmbas

From ActivityOwnerWiki
Jump to: navigation, search
'#Reference {00020813-0000-0000-C000-000000000046}#1.0#9#C:\Program Files (x86)\Microsoft Office\Office12\XL5EN32.OLB#Microsoft Excel 5.0 Object Library
'ao_map2excel 08Dec2010 http://creativecommons.org/licenses/by-nc-nd/3.0/
'recent changes
'set max column width
'add option to added extended information
'add links to topic and its hyperlink
'fix catalyst bug
'07May2010 -- add notes to extended option
'08Dec2010 -- try to add text labels (tags) to extended option, fix title level bug, warn if exporting just a branch
'use common functions
'#uses "ao_common.mmbas"
Option Explicit
Sub Main
	Dim parent As Topic
	Dim sheet As Object
	Dim t As Topic
	Dim fillin As Boolean
	Dim rownum As Integer
	Dim colnum As Integer
	Dim maxcolnum As Integer
	Dim addextended As Boolean
	Dim i As Integer
	Const extended=9
	fillin      = MsgBox("Do you want a full tabular export? Click No for Outline",vbYesNo,"Map2Excel")=vbYes
	addextended =MsgBox("Add extended information (dates,resources,priority,notes)?",vbYesNo,"Map2Excel")=vbYes
	Dim excelapp As Excel.Application
	Set excelapp=CreateObject("excel.application")
	excelapp.Visible=True
	Set sheet=excelapp.Workbooks.Add.Sheets(1)
	rownum=2
	If addextended Then colnum=1+extended Else colnum=1
	maxcolnum=1
	If ActiveDocument.Selection.Count>0 Then
		If Not ActiveDocument.Selection.PrimaryTopic.IsCentralTopic Then
			If MsgBox("Do you want to export selected topic instead of whole map?",vbYesNo)=vbYes Then
				Set parent=ActiveDocument.Selection.PrimaryTopic
			Else
				Set parent=ActiveDocument.CentralTopic
			End If
		Else
			Set parent=ActiveDocument.CentralTopic
		End If
	Else
		Set parent=ActiveDocument.CentralTopic
	End If
	For Each t In parent.AllSubTopics
		exportinfo t,rownum,colnum,sheet,fillin, addextended,maxcolnum
	Next
	For i=extended+1 To maxcolnum
		sheet.Cells(1,i)="Level" & Str(i-extended)
	Next
	If addextended Then
		sheet.Cells(1,1)="Topic"
		sheet.Cells(1,2)="Link"
		sheet.Cells(1,3)="StartDate"
		sheet.Cells(1,4)="DueDate"
		sheet.Cells(1,5)="Priority"
		sheet.Cells(1,6)="Resources"
		sheet.Cells(1,7)="PctComplete"
		sheet.Cells(1,8)="Notes"
		sheet.Cells(1,9)="Tags"
	End If
	Set excelapp=Nothing
	Set sheet=Nothing
	Set parent=Nothing
	Set t=Nothing
End Sub
Sub exportinfo(ByRef t As Topic,ByRef rownum As Integer, ByRef colnum As Integer, ByRef sheet As Object,ByRef fillin As Boolean, ByRef addextended As Boolean, ByRef maxcolnum As Integer)
	Dim st As Topic
	Dim i As Integer
	Const MaxColWidth=80
	sheet.Cells(rownum,colnum)=t.Text
	If sheet.Columns(colnum).ColumnWidth<Len(t.Text) Then
		If Len(t.Text)>MaxColWidth Then
			sheet.Columns(colnum).ColumnWidth=MaxColWidth
		Else
			sheet.Columns(colnum).ColumnWidth=Len(t.Text)
		End If
	End If
	If  fillin And colnum>1 And rownum>1 Then
		For i=1 To colnum-1
			If sheet.Cells(rownum,i)="" Then sheet.Cells(rownum,i)=sheet.Cells(rownum-1,i)
		Next
	End If
	If t.AllSubTopics.Count=0 Then
		If addextended Then
			sheet.Cells(rownum,1).Formula = "=Hyperlink(" & Chr(34) & LinkToThisTopic(t) & Chr(34) & "," & Chr(34) & "topic" & Chr(34) & ")"
			If t.HasHyperlink Then
				If t.Hyperlink.IsValid Then
					On Error Resume Next
					sheet.Cells(rownum,2).Formula = "=Hyperlink(" & Chr(34) & LinktoThisTopicHyperlink(t) & Chr(34) & "," & Chr(34) & "link" & Chr(34) & ")"
					If Err.Number>0 Then
						sheet.Cells(rownum,2)=" "
						Err.Clear
					End If
					On Error GoTo 0
				End If
			Else
				sheet.Cells(rownum,2)=" "
			End If
			If t.Task.StartDate>0 Then sheet.Cells(rownum,3)=t.Task.StartDate
			If t.Task.DueDate>0 Then sheet.Cells(rownum,4)=t.Task.DueDate
			sheet.Cells(rownum,3).NumberFormat="mm/dd/yyyy"
			sheet.Cells(rownum,4).NumberFormat="mm/dd/yyyy"
			If t.Task.Priority>0 Then sheet.Cells(rownum,5)=t.Task.Priority
			sheet.Cells(rownum,6)=t.Task.Resources
			If Len(t.Task.Resources)>0 Then
				If Len(t.Task.Resources)>sheet.Columns(6).ColumnWidth Then
					sheet.Columns(6).ColumnWidth=Len(t.Task.Resources)
				End If
			End If
			If t.Task.Complete>-1 Then	sheet.Cells(rownum,7)=t.Task.Complete
			If t.TextLabels.Count>0 Then
				For i = 1 To t.TextLabels.Count
					sheet.Cells(rownum,9) = sheet.Cells(rownum,9) & t.TextLabels.Item(1).Name
					If i< t.TextLabels.Count Then sheet.Cells(rownum,9) = sheet.Cells(rownum,9) & ","
				Next
			End If
			If Len(t.Notes.Text)>0 Then
				sheet.Cells(rownum,8)=t.Notes.Text
			End If

		End If
		If colnum>maxcolnum Then maxcolnum=colnum
		rownum=rownum+1
	Else
		colnum=colnum+1
		If colnum>maxcolnum Then maxcolnum=colnum
		For Each st In t.AllSubTopics
			exportinfo st,rownum,colnum,sheet, fillin, addextended,maxcolnum
		Next
		colnum=colnum-1
	End If
	Set st=Nothing
End Sub