Ao common.mmbas

From ActivityOwnerWiki

'23Jan2010 ao_common.mmbas generic functions used by ao-tools (e.g. mindreader and mark task complete)
'Code protected under http://creativecommons.org/licenses/by-nc-nd/3.0/
'Contact info@activityowner.com for persmission to waive restrictions
'http://wiki.activityowner.com
'recent revision
'09Jan09 -- generic routines split out of mindreadernlp.mmbas and mark_task_complete.mmbas
'revise getmap routine
're-revise getmap...
'save configdoc after version check
'close configdoc if version upgrade chosen
'differentiate between relative and full paths in getmap
'check version of ao-common
'confirm version checks with user
'fix date bug in version check
'change sound to recycle from chirp
'fix followhyperlink
'fix version information
'add rtrim to createmainbranch to avoid missing branches with trailing spaces
'25Jan -- trap error for empty last upgrade
'26Jan -- bug fix for mjc hyperlinks
'27Jan -- avoid errors on missing callouts in naa functions
'06Feb -- add block to reference branch
'09Feb -- speed up createmainbranch, add optionlocal to override options using notes (in reference branch) used in mtc initially
'15Feb -- option to feed option utilities the option topic to improve speed
'16Feb -- comment out sw function
'17Feb -- speed up openmaphidden and avoid bringing map into focus when open
'26Feb -- speed up stcreate
'13Mar -- Avoid prompting for new completed maps each month
'19Apr -- change version check strategy
'29Dec09 -- merge in subroutines from export routines
'30Dec09 -- add closehiddenmaps procedure
'31Dec09 -- fix bug in hyperlink writing
'23Jan10 -- fix bug in multi-line processing introduced when trying to improve synch
'used in SW timer
Option Explicit
Global mtime As Double
Global dtime As Double
Sub VersionCheck(ByRef VersionpageLink As String, ByRef programname As String, programversion As String, ByRef ConfigDoc As Document)
'used by various main programs.  Also checks version of ao-common
	Const AOCommonVersion="20091231"
	Dim VersionCheckFrequency As Integer
	VersionCheckFrequency=Val(getoption("versioncheckfrequency",ConfigDoc))
	If VersionCheckFrequency>0 Then
		If DateAdd("d",VersionCheckFrequency, getoption("lastversioncheck",ConfigDoc)) <= Date Then
		   If MsgBox("Would you like to check to see if this macro is up to date?",vbYesNo)=vbYes Then
		   			Dim ie As Object
                    Set ie = CreateObject("InternetExplorer.Application")
                    ie.Visible = True
                    ie.navigate VersionpageLink & "?name=" & programname & "&installed=" & programversion
                    Set ie = Nothing
			End If
			setoption "lastversioncheck",Str(Date),ConfigDoc
			ConfigDoc.Save
		End If
	End If
End Sub
'--------------------------------------------------------------
'True/False Checks on Maps and topics
'--------------------------------------------------------------
Function f_IsADashboardMap(ByVal m_Doc As Document) As Boolean
' Check if a map is a dashboard map
Const T_uriGRM = "http://schemas.gyronix.com/resultmanager"
Const T_DashSource = "DashSource" ' source map used to generate dashboard
Dim s_1 As String
s_1 = m_Doc.CentralTopic.Attributes(T_uriGRM).GetAttributeValue(T_DashSource) 'Read source: this Is Not Empty If a destination (generated) map
f_IsADashboardMap = (Len(s_1) > 0) ' has a source path, so is a real dashboard
End Function
Function isvisible(tmapname As String) As Boolean
	Dim doc As Document
 	isvisible=False
	For Each doc In VisibleDocuments
   		If doc.FullName=tmapname Then
   			isvisible=True
   			Exit Function
   		End If
	Next
	Set doc = Nothing
End Function
Function isopen(tmapname As String) As Boolean
	Dim doc As Document
 	isopen=False
	For Each doc In Documents
   		If doc.FullName=tmapname Then
   			isopen=True
   			Exit Function
   		End If
	Next
	Set doc = Nothing
End Function
Function isclone(ByRef tt As Topic, ByRef t As Topic) As Boolean
	If Not tt.HasHyperlink Then
		isclone=False
	Else
		If (InStr(tt.Hyperlink.Address,"http://mjc.mindjet.com/openlink")>0) Then
			If (t.Hyperlink.Address = tt.Hyperlink.Address) Then
				isclone=True
			End If
		Else
			If t.Hyperlink.TopicBookmarkGuid=tt.Hyperlink.TopicBookmarkGuid And Len(tt.Hyperlink.TopicBookmarkGuid)>0  Then
				isclone=True
			End If
		End If
	End If
End Function
Function isred(ByRef t As Topic) As Boolean
'used by naa
	Dim red As Byte
	Dim green As Byte
	Dim blue As Byte
	Dim alpha As Byte
	t.TextColor.GetARGB(alpha,red,green,blue)
	isred=(red=255)
End Function
Function isrepeating(ByRef t As Topic) As Boolean
'used by naa
	Dim i As Integer
	Dim cat As String
	cat= LCase(t.Task.Categories)
	If cat="" And t.TextLabels.IsValid Then
		For i = 1 To t.TextLabels.Count
			cat = cat & t.TextLabels.Item(i).Name
		Next
	End If
	If cat="" And Not t.TextLabels.IsValid Then   'this is a hack that will yield false positives
		cat = cat & t.Xml
	End If
  'code below will need modification if additional repeating categories are added
   isrepeating = InStr(cat,"ly")>0 Or InStr(cat,"day")>0 Or InStr(cat,"every")>0 Or InStr(cat,"each")>0 Or InStr(cat,"endof")>0 Or InStr(cat,"biannual")>0
End Function
Function parentcontains(ByRef t As Topic, sometext As String ) As Boolean
'used by naa
	If Not (t.ParentTopic Is Nothing) Then
		parentcontains=InStr(LCase(t.ParentTopic.Text),LCase(sometext))>0
	Else
		parentcontains=False
	End If
End Function

'--------------------------------------------------------------
'Sounds
'--------------------------------------------------------------
Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
    (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Sub PlaySoundchirp()
        'Substitute the path and filename of the sound you want to play
        Call sndPlaySound32("c:\windows\media\recycle.wav", 0)
End Sub
Function followedhyperlink(ByRef t As Topic,ByRef doccurrent As Document) As Topic
	Dim timeout As Double
	Dim d As Document
	Dim tt As Topic
	On Error Resume Next
	If (Not InStr(t.Hyperlink.Address,"http://")>0) And Len(t.Hyperlink.TopicBookmarkGuid)>0 Then
		If isabsolute(t.Hyperlink.Address) Then
			Set d=FindMap(t.Hyperlink.Address)
			If d Is Nothing Then Set d=Documents.Open(t.Hyperlink.Address,"",isvisible(t.Hyperlink.Address))
		Else
			Set d=FindMap(t.Document.Path & t.Hyperlink.Address)
			If d Is Nothing Then Set d=Documents.Open(t.Document.Path & t.Hyperlink.Address,"",isvisible(t.Document.Path & t.Hyperlink.Address))
		End If
		If Not d Is Nothing Then
			For Each tt In d.Range(mmRangeAllTopics)
				If t.Hyperlink.TopicBookmarkGuid=tt.Guid Then
					Set followedhyperlink=tt
					Set d=Nothing
					Set tt=Nothing
					Exit Function
				End If
			Next
		End If
	End If
	t.Hyperlink.Follow
	timeout=0
	While doccurrent.FullName=ActiveDocument.FullName
		Wait 0.2
		timeout=timeout+1
		If timeout>50 Then
			If InStr(t.Hyperlink.Address,"http://mjc.mindjet.com/openlink")>0 Then MsgBox "mjc timeout"
			Exit While
		End If
	Wend
	Set followedhyperlink=ActiveDocument.Selection.PrimaryTopic
End Function
Function st_create(ByRef tmap As Document,ByRef t As Topic, stext As String) As Topic
'find or create a year/month/date branch in completed log
    Dim found As Boolean
    Dim i As Integer
	found=False
	stext=Trim(stext)
	i=t.AllSubTopics.Count 'search from top
	While Not found And i>0
    	If t.AllSubTopics(i).Text=stext Then
    	   Set st_create=t.AllSubTopics(i)
    	   found=True
    	   If Val(t.AllSubTopics(i).Text)<Val(stext) Then Exit While
        End If
        i=i-1
    Wend
   If Not found Then Set st_create=t.AddSubTopic(stext)
End Function
Sub copytocalendarlog(ByRef tmap As Document, ByRef tt As Topic)
	Dim t As Topic
	Set t=st_create(tmap,tmap.CentralTopic,"Complete")
	Set t=st_create(tmap,t,Str(Year(Date)))
	Set t=st_create(tmap,t,Str(Month(Date)))
	Set t=st_create(tmap,t,Str(Date))
	Set t= t.AddSubTopic("")
	t.Xml=tt.Xml
	t.Task.Complete=100
	Set t =Nothing
End Sub
Sub copytoRefcalendarlog(ByRef tmap As Document, ByRef tt As Topic, ByRef reftext As String)
'copy completed task to reference branch of tmap in calendar outline
	Dim t As Topic
	Set t=st_create(tmap,tmap.CentralTopic,reftext)
	If Not t.Icons.HasStockIcon(mmStockIconNoEntry) Then t.Icons.AddStockIcon(mmStockIconNoEntry)
	Set t=st_create(tmap,t,Str(Year(Date)))
	Set t=st_create(tmap,t,Str(Month(Date)))
	Set t=st_create(tmap,t,Str(Date))
	Set t= t.AddSubTopic("")
	t.Xml=tt.Xml
	t.Task.Complete=100
	Set t =Nothing
End Sub
'-----------------------------------------------------------------------
'Configuration Map Functions
'-----------------------------------------------------------------------------------------
Sub createoption(setting As String, settingvalue As String, ByRef ConfigDoc As Document)
'create and set option if it isn't already set
	Dim s As Topic
	Set s=createmainbranch("options",ConfigDoc)'create option branch if necessary
	createkeyword s,setting,settingvalue, "1", "0"
	Set s=Nothing
End Sub
Sub deleteoption(setting As String, ByRef ConfigDoc As Document)
	Dim s As Topic
	Set s=createmainbranch("options",ConfigDoc)'create option branch if necessary
	deletekeyword s,setting,"1","0"
	Set s=Nothing
End Sub
Sub setoption(setting As String, settingvalue As String, ByRef ConfigDoc As Document)
'Set option "setting" to "settingvalue" in ConfigDoc
	Dim found As Boolean
	Dim t As Topic
	Dim s As Topic
	Dim ss As Topic
	found = False
	Set s=createmainbranch("options",ConfigDoc)
	found=False
	For Each t In s.AllSubTopics
		If t.Text=setting Then
			found =True
			t.Notes.Text=settingvalue
		End If
	Next
	If Not found Then
		Set ss= s.AddSubTopic(setting)
		ss.Notes.Text=settingvalue
	End If
	Set t =Nothing
	Set s =Nothing
End Sub
Function optiontrue(ByRef moption As String, ByRef ConfigDoc As Document, Optional ByRef optionbranch As Topic) As Boolean
	Dim o As String
	o = getoption(moption,ConfigDoc, optionbranch)
	If Trim(o)="1" Then
		optiontrue=True
	ElseIf Trim(o)="0" Then
		optiontrue=False
	Else
		If MsgBox("Option:" & moption & " has not been set correctly.  Would you like to set it true?",vbYesNo)=vbYes Then
			createoption moption, "1", ConfigDoc
			optiontrue=True
		Else
			createoption moption, "0", ConfigDoc
			optiontrue=False
		End If
	End If
End Function

Function getoption(ByRef mroption As String,ByRef ConfigDoc As Document, Optional ByRef s As Topic) As String
'get value for mroption from ConfigDoc
	Dim t As Topic
	If s Is Nothing Then Set s =createmainbranch("options",ConfigDoc)
	getoption=""
	For Each t In s.AllSubTopics
		If t.Text=mroption Then
			getoption=t.Notes.Text
			Exit Function
		End If
	Next
	Debug.Print "Option " & mroption & " not found in configuration map"
	Set t=Nothing
	Set s=Nothing
End Function
Sub usersetoption(ByRef ConfigDoc As Document, ParseText As String)
'Allow user to set option values with "m"
	Dim opt As String
	Dim optvalue As String
	Dim firstcolon As Integer
	Dim secondcolon As Integer
	firstcolon=InStr(ParseText,":")
	secondcolon=InStrRev(ParseText,":")
	opt =Mid(ParseText,firstcolon+1,secondcolon-firstcolon-1)
	optvalue=Mid(ParseText,secondcolon+1)
	setoption opt,optvalue,ConfigDoc
	MsgBox("Option " & opt & " set to " & optvalue)
End Sub
Sub usergetoption(ByRef ConfigDoc As Document, ParseText As String)
'Allow user to get current option values with "m"
	Dim opt As String
	Dim optvalue As String
	Dim firstcolon As Integer
	firstcolon=InStr(ParseText,":")
	opt =Mid(ParseText,firstcolon+1)
	optvalue=getoption(opt,ConfigDoc)
	MsgBox(opt &" value is " & optvalue)
End Sub

Function middlestr(sometext As String, starting As Integer, ending As Integer) As String
	middlestr=Mid(sometext,starting, ending-starting)
End Function
Function createmainbranch(mainstring As String, ConfigDoc As Document, Optional callouttext As String) As Topic
'find or create a main topic for a map

	Dim c As Topic
	If Not ConfigDoc Is Nothing Then
		Set createmainbranch = findmainbranch(mainstring, ConfigDoc)
		If createmainbranch Is Nothing Then
			Set createmainbranch = ConfigDoc.CentralTopic.AddBalancedSubTopic(mainstring)
			If Not callouttext = "" Then
				Set c=createmainbranch.CalloutTopics.Add
				c.Text = callouttext
				Set c=Nothing
			End If
		End If
	End If
End Function
Function findmainbranch(mainstring As String, ConfigDoc As Document) As Topic
'find main topic for a map if it exists
	Dim i As Integer
	If Not ConfigDoc Is Nothing Then
		i=ConfigDoc.CentralTopic.AllSubTopics.Count
		While i>0
			If LCase(RTrim(ConfigDoc.CentralTopic.AllSubTopics(i).Text))=LCase(RTrim(mainstring)) Then
				Set findmainbranch=ConfigDoc.CentralTopic.AllSubTopics(i)
				Exit Function
			End If
			i=i-1
		Wend
	End If
End Function
Sub deletemainbranch(mainstring As String, ConfigDoc As Document)
'find or create a main topic for a map
	Dim found As Boolean
	Dim i As Integer
	i=ConfigDoc.CentralTopic.AllSubTopics.Count
	While i>0 And Not found
		If LCase(ConfigDoc.CentralTopic.AllSubTopics(i).Text)=LCase(mainstring) Then
			found=True
			ConfigDoc.CentralTopic.AllSubTopics(i).Delete
		End If
		i=i-1
	Wend
End Sub

Sub FixBadOutlinkerLinks(ByRef doc As Document)
	'versions of mindreader before 22Jan08 added outlinker outlook links with "|message" on end if "link" keyword in task
	Dim t As Topic
	For Each t In doc.Range(mmRangeAllTopics)
		If t.HasHyperlink Then
			If InStr(t.Hyperlink.Address,"|")>0 Then
				t.Hyperlink.Address = Left(t.Hyperlink.Address,InStr(t.Hyperlink.Address,"|")-1)
			End If
		End If
	Next
	Set t=Nothing
End Sub
Sub createkeyword(ByRef a As Topic, ByRef keyword As String, ByRef code As String, partofupgrade As String, lastupgrade As String)
'creates a new keyword in main branch "a" with value "code".  If it already exists, don't change its value
	Dim b As Topic
	Dim found As Boolean
	If Eval(partofupgrade)>Eval(lastupgrade) Then
		found=False
		For Each b In a.AllSubTopics
			If LCase(b.Text)=LCase(keyword) Then found=True
		Next
		If Not found Then
			Set b=a.AddSubTopic(keyword)
			b.Notes.Text=code
		End If
		Set b=Nothing
	End If
End Sub
Sub deletekeyword(ByRef a As Topic, ByRef keyword As String, partofupgrade As String, lastupgrade As String)
'Delete a keyword in main branch a
	Dim b As Topic
	If Eval(partofupgrade)>Eval(lastupgrade) Then
		For Each b In a.AllSubTopics
			If LCase(b.Text)=LCase(keyword) Then b.Delete
		Next
		Set b=Nothing
	End If
End Sub
Sub WarnFirstDeleteKeyword(ByRef a As Topic, ByRef keyword As String, partofupgrade As String, lastupgrade As String)
'Delete a keyword in main branch a
	Dim b As Topic
	If Eval(partofupgrade)>Eval(lastupgrade) Then
		For Each b In a.AllSubTopics
			If LCase(b.Text)=LCase(keyword) Then
				MsgBox("Note: Program is removing the _" & keyword & "_ keyword from the " & a.Text & " branch to avoid issues")
				b.Delete
			End If
		Next
		Set b=Nothing
	End If
End Sub
Sub addkeyword(ByRef a As Topic, ByRef keyword As String, ByRef code As String, partofupgrade As String, lastupgrade As String)
'Add a keyword underneath topic a.  Set value if it exists
	Dim b As Topic
	Dim found As Boolean
	If lastupgrade="" Then lastupgrade="0"
	If Eval(partofupgrade)>Eval(lastupgrade) Then
		found=False
		For Each b In a.AllSubTopics
			If b.Text=keyword Then
				found=True
				b.Notes.Text=code
			End If
		Next
		If Not found Then
			Set b=a.AddSubTopic(keyword)
			b.Notes.Text=code
		End If
		Set b=Nothing
	End If
End Sub
Sub addtriplet(ByRef a As Topic, ByRef keyword As String, ByRef code1 As String, ByRef code2 As String, ByRef code3 As String,	partofupgrade As String, lastupgrade As String)
'Add a triplet underneath topic a.  Set value if it exists
	Dim b As Topic
	Dim found As Boolean
	If Eval(partofupgrade)>Eval(lastupgrade) Then
		found=False
		For Each b In a.AllSubTopics
			If b.Text=keyword Then
				found=True
				b.AllSubTopics.Item(1).Delete
				b.AllSubTopics.Item(1).Delete
				b.AllSubTopics.Item(1).Delete
				b.AddSubTopic(code1)
				b.AddSubTopic(code2)
				b.AddSubTopic(code3)
			End If
		Next
		If Not found Then
			Set b=a.AddSubTopic(keyword)
			b.AddSubTopic(code1)
			b.AddSubTopic(code2)
			b.AddSubTopic(code3)
		End If
		Set b=Nothing
	End If
End Sub

Function getmap(ByRef mapname As String) As Document
'opens map named mapname in my maps directory.  Create it if not found
Dim fullname As String
Dim createit As Boolean
If InStr(mapname,":\")>0 Or InStr(mapname,"\\")>0 Then
	fullname=mapname
Else
	fullname=GetPath(mmDirectoryMyMaps) & mapname
End If
On Error Resume Next
Set getmap=Documents.Open(fullname,"",isvisible(fullname))
On Error GoTo 0
If getmap Is Nothing Then
	createit = False
	createit = InStr(LCase(fullname),"completed")>0 And Not InStr(LCase(fullname),"completedconfig")
	If Not createit Then
		createit = MsgBox(fullname & " was not found. Would you like to create it? If this is the first time you are running program or just upgraded, click OK.", vbOkCancel)=vbOK
	End If
	If createit Then
     	Set getmap= Documents.Add(False)
     	On Error Resume Next
     	getmap.SaveAs(fullname)
     	If Err.Number>0 Then
     		MsgBox "Error:" & Err.Description
     		End
     	End If
     	On Error GoTo 0
     Else
    	End
    End If
End If

End Function
Sub checkforduplicates(ConfigDoc)
'duplicate entries in configuration maps can cause problems.  Check for them upon each upgrade
	Dim m As Topic
	Dim i As Integer
	Dim j As Integer
	Dim notfinished As Boolean
	Dim deletethis As Topic
	notfinished=True
	While notfinished
		notfinished=False
		For Each m In ConfigDoc.CentralTopic.AllSubTopics
			If m.AllSubTopics.Count>1 Then
				For i =1 To m.AllSubTopics.Count
					For j = i To m.AllSubTopics.Count
						If Not(i=j) And m.AllSubTopics.Item(i).Text=m.AllSubTopics.Item(j).Text Then
							MsgBox("You had duplicate entries for[" &  m.AllSubTopics.Item(i).Text & "] in configuration map branch [" & m.Text & "] at position " & i & " And " & j & ". The 2nd was deleted.")
							notfinished=True
							Set deletethis = m.AllSubTopics.Item(j)
						End If
					Next
				Next
			End If
		Next
		If notfinished Then
			deletethis.Delete
		End If
	Wend
	Set m=Nothing
	Set deletethis = Nothing
End Sub
Sub copybranchtomap(ByRef Parent As Topic, Title As String, ByRef destmap As Document)
'used by naa
	Dim t As Topic
	Dim tt As Topic
    For Each t In Parent.AllSubTopics
    	If LCase(t.Text)=LCase(Title) Then
    		For Each tt In t.AllSubTopics
    			destmap.CentralTopic.AddSubTopic("").Xml = tt.Xml
    		Next
    	End If
	Next
	Set t=Nothing
	Set tt=Nothing
End Sub
Sub copybranchcontainingtomap(ByRef Parent As Topic, Title As String, ByRef destmap As Document)
'used by naa
	Dim t As Topic
	Dim tt As Topic
    For Each t In Parent.AllSubTopics
    	If InStr(LCase(t.Text),LCase(Title))>0 Then
			For Each tt In t.AllSubTopics
    			destmap.CentralTopic.AddSubTopic("").Xml = tt.Xml
    		Next
    	End If
	Next
	Set t=Nothing
	Set tt=Nothing
End Sub
Function TotalActivities(map As Document) As Integer
'used by naa
 	Dim t As Topic
 	Dim n As Integer
 	n=0
	For Each t In map.Range(mmRangeAllTopics)
		If Not t.Task.IsEmpty Then
			If Not t.IsCalloutTopic Then
				If t.Task.Complete<100 Then
					n=n+1
				End If
			End If
		End If
	Next
	TotalActivities=n
End Function


Function TotalRedActivities(map As Document) As Integer
'used by naa
 	Dim t As Topic
	Dim n As Integer
 	n=0
	For Each t In map.Range(mmRangeAllTopics)
		If Not t.Task.IsEmpty Then
			If Not t.IsCalloutTopic Then
				If isred(t) Then
					If t.Task.Complete<100 Then
						n=n+1
					End If
				End If
			End If
		End If
	Next
	TotalRedActivities=n
	Set t=Nothing
End Function
Function TotalRedCallouts(map As Document) As Integer
'used by naa
 	Dim t As Topic
	Dim n As Integer
 	n=0
	For Each t In map.Range(mmRangeAllTopics)
		If Not t.Task.IsEmpty Then
			If t.IsCalloutTopic Then
				If isred(t) Then
					If t.Task.Complete<100 Then
						n=n+1
					End If
				End If
			End If
		End If
	Next
	TotalRedCallouts=n
	Set t=Nothing
End Function
Function TotalRedActivitiesWithParentContaining(map As Document,s As String) As Integer
'used by naa
 	Dim t As Topic
 	Dim n As Integer
	n=0
 	For Each t In map.Range(mmRangeAllTopics)
		If Not t.Task.IsEmpty Then
			If Not t.IsCalloutTopic Then
				If InStr(t.ParentTopic.Text,s)>0 Then
					If isred(t) Then
						n=n+1
					End If
				End If
			End If
		End If
	Next
	TotalRedActivitiesWithParentContaining=n
	Set t=Nothing
End Function
Function TotalActivitiesWithParentContainingandnoduedate(map As Document,s As String) As Integer
'used by naa
 	Dim t As Topic
 	Dim n As Integer
	n=0
 	For Each t In map.Range(mmRangeAllTopics)
		If Not t.Task.IsEmpty Then
			If Not t.IsCalloutTopic Then
				If InStr(t.ParentTopic.Text,s)>0 Then
					If t.Task.DueDate<=0 Then
						If t.CalloutTopics.Count>0 Then
								If t.CalloutTopics.Item(1).Task.DueDate<=0 Then
										n=n+1
								End If
							End If
					End If
				End If
			End If
		End If
	Next
	TotalActivitiesWithParentContainingandnoduedate=n
	Set t=Nothing
End Function
Function TotalActivitiesWithParentContaining(map As Document,s As String) As Integer
'used by naa
 	Dim t As Topic
 	Dim n As Integer
	n=0
 	For Each t In map.Range(mmRangeAllTopics)
		If Not t.Task.IsEmpty Then
			If Not t.IsCalloutTopic Then
				If InStr(t.ParentTopic.Text,s)>0 Then
						n=n+1
				End If
			End If
		End If
	Next
	TotalActivitiesWithParentContaining=n
	Set t=Nothing
End Function
Function arrayaverage(age As Variant,numdatedactions As Integer) As Double
'used by naa
	Dim i As Integer
	For i=1 To numdatedactions
		arrayaverage=arrayaverage+age(i)/numdatedactions
	Next
End Function
Function maxbranch(ByRef doc As Document) As Topic
'used by naa
	Dim t As Topic
	Dim st As Topic
	Dim root As Boolean
	Dim maxcount As Integer
	maxcount=0
	For Each t In doc.CentralTopic.AllSubTopics
		If t.AllSubTopics.Count>0 Then
			root=True
			For Each st In t.AllSubTopics
			    If st.AllSubTopics.Count>0 Then
			    	root=False
					If st.AllSubTopics.Count > maxcount Then
						Set maxbranch=st
						maxcount=t.AllSubTopics.Count
					End If
				End If
			Next
			If root=True Then
				If t.AllSubTopics.Count>maxcount Then
					Set maxbranch=t
					maxcount=t.AllSubTopics.Count
				End If
			End If
		End If
	Next
	Set t=Nothing
	Set st=Nothing
End Function
Function cat(ByRef t As Topic) As String
'used by naa
	Dim i As Integer
	cat= LCase(t.Task.Categories)
	If cat="" And t.TextLabels.IsValid Then
		For i = 1 To t.TextLabels.Count
			cat = cat & ", " & t.TextLabels.Item(i).Name

		Next
	End If
	If gethidcat(t)="" Then
		If cat="" And Not t.TextLabels.IsValid Then   'this is a hack that will yield false positives
			cat = cat & ", " & t.Xml
		End If
	Else
		cat = gethidcat(t) & ", " & cat
	End If
End Function
Function gethidcat(t As Topic) As String
'used by naa
	Dim s As String
	If InStr(t.Xml,"HidCats")>0 Then
		s=Mid(t.Xml,InStr(t.Xml,"HidCats=")+9)
		s=Mid(s,1,InStr(s,Chr(34))-1)
	End If
	If Len(s)=0 And InStr(t.Xml,"MirCat")>0 Then
		s=Mid(t.Xml,InStr(t.Xml,"MirCat=")+8)
		s=Mid(s,1,InStr(s,Chr(34))-1)
	End If
	gethidcat=s
End Function
Function getfirstarea(ByRef t As Topic) As String
'used by naa
	Dim cats As String
	Dim start As Integer
	Dim comma As Integer
	cats=cat(t)
	getfirstarea=""
	If InStr(cats,"^")>0 Then
		cats=Mid(cats,InStr(cats,"^")+1)
		If InStr(cats,";")>0 Then
			getfirstarea=Mid(cats,1,InStr(cats,";")-1)
		ElseIf InStr(cats,",")>0 Then
			getfirstarea=Mid(cats,1, InStr(cats,",")-1)
		Else
			getfirstarea=cats
		End If
	Else
		cats=gethidcat(t)
		start=InStr(cats,"^")
		If start>0 Then
			comma = InStr(Mid(cats,start),";")
			If Not comma>0 Then
				comma=InStr(Mid(cats,start),",")
			End If
		Else
			comma=0
		End If
		If start>0 Then
			If comma>0 Then
				getfirstarea=Mid(cats,start+1,comma-2)
			Else
				getfirstarea=Mid(cats,start+1)
			End If
		End If
	End If
End Function
Function GetNewVersion(ByRef ProgramVersion As String, ByRef VersionMapLink As String) As Boolean
'generic version checker
	Dim VersionDoc As Document
	Dim releasedversion As String
	GetNewVersion=False
	On Error GoTo x1
	Set VersionDoc=Documents.Open(VersionMapLink,"",False)
	On Error GoTo x2
	releasedversion=VersionDoc.CentralTopic.Notes.Text
	On Error GoTo 0
	If Err.Number>0 Then
	 x1: Debug.Print "Version map not accessible": Exit Function
	 x2: Debug.Print "Could not get current version number from " & VersionMapLink : Exit Function
	End If
	Debug.Print Val(ProgramVersion)
	Debug.Print Val(releasedversion)
	Debug.Print Val(ProgramVersion)-Val(releasedversion)
	If Val(ProgramVersion)<Val(releasedversion) Then
		GetNewVersion=MsgBox("You currently have version " & ProgramVersion & " and the most recent version is " & releasedversion & ".  Would you like to visit the upgrade page?",vbYesNo)=vbYes
	Else
		GetNewVersion=False
		Debug.Print "You are using version " & ProgramVersion & " and the latest released version is " & releasedversion & ". You appear To be up to date."
	End If
	If GetNewVersion Then VersionDoc.CentralTopic.Hyperlink.Follow
	VersionDoc.Close
End Function
Function issaved(ByRef doc As Document)
'used by mindreaderopen
	issaved=isworkspacemap(doc) Or Not doc.FullName=doc.Name
End Function
Function isworkspacemap(ByRef doc As Document)
	'used by mindreaderopen
	Dim prefix As String
	Dim issaved As Boolean
	'attempt to determine if has been saved or is a workspace map
	prefix = "Map"
	issaved = True
	If Left(doc.FullName, Len(prefix)) = prefix Then
	    issaved= Not IsNumeric(Right(doc.FullName,Len(doc.FullName)-Len(prefix)))
	End If
	isworkspacemap = (doc.FullName=doc.Name) And issaved
End Function
Function isabsolute(ByRef fname As String) As Boolean
'determine if a path is relative or absolute
	isabsolute = InStr(fname,"\\")>0 Or InStr(fname,":\")>0
End Function
Function ismindjetconnectlink(ByRef link As Hyperlink) As Boolean
	ismindjetconnectlink= InStr(LCase(link.Address),"http://mjc.mindjet.com/openlink")=1
End Function
Sub CloseHiddenMaps
'historically routines have left maps open hidden to improve performance but
'this leads to conflicts when using multi-computer setups
Dim doc As Document
Dim visdoc As Document
Dim found As Boolean
For Each doc In Documents(True)
	If Not isvisible(doc.FullName) Then
		If doc.IsModified Then doc.Save
		If InStr(LCase(doc.Name),"config")=0 Then doc.Close
	End If
Next
End Sub

Function OpenMapHidden(ByRef mapname As String) As Document
	'open map hidden unless already visible
	sw("in openmaphidden")
	Set OpenMapHidden=FindMap(mapname)
	If OpenMapHidden Is Nothing Then
		Set OpenMapHidden = Documents.Open(mapname,"",False)
	End If
	sw("leaving openmaphidden")
End Function
Function FindMap(ByRef mapname As String) As Document
	Dim doc As Document
	For Each doc In Documents
   		If doc.FullName=mapname Then
   			Set FindMap=doc
   			Set doc = Nothing
   			Exit Function
   		End If
	Next
	Set FindMap=Nothing
End Function
Function LinkToThisTopic(ByRef t As Topic) As String
    LinkToThisTopic= "mj-map:///" & Replace(t.Document.FullName," ","%20") & "#oid=" & guid2oid(t.Guid)
End Function
Function LinktoThisTopicHyperlink(ByRef t As Topic) As String
	Dim prefix As String
	Dim postfix As String
	Dim addr As String
	Dim guid As String
	If t.HasHyperlink Then
		If t.Hyperlink.IsValid Then
			If InStr(t.Hyperlink.Address,":\")>0 Or InStr(t.Hyperlink.Address,"\\")>0 Or InStr(t.Hyperlink.Address,"mj-map:/")>0 Or InStr(t.Hyperlink.Address,"Outlook")>0 Or InStr(t.Hyperlink.Address,"http")>0 Then
	           	addr=t.Hyperlink.Address
	        Else
				addr=t.Document.Path & "\" & t.Hyperlink.Address
	        End If
	        guid=t.Hyperlink.TopicBookmarkGuid
	        If addr="" Then 'blank hyperlink indicates internal link to same map
	         	addr=t.Document.FullName
            End If
	        If Not guid="" Then
		    	prefix="mj-map:///"
 			Else
 				prefix=""
 			End If
			If Not guid="" Then
				postfix="#oid=" & guid2oid(guid)
			Else
				postfix =""
			End If
		End If
	End If
	If InStr(t.Hyperlink.Address,"https")>0 Then
		LinktoThisTopicHyperlink=t.Hyperlink.Address
	Else
		LinktoThisTopicHyperlink=prefix & addr & postfix
	End If
End Function
Function guid2oid(ByVal base64String As String) '28Nov08 http://creativecommons.org/licenses/by-sa/2.5/ http://www.activityowner.com
  'convert topic.guid to oid
  'Derived from: 1999 Antonin Foller, Motobit Software, http://www.motobit.com/tips/detpg_Base64/
  Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  Dim ngroupall As String
  Dim dataLength, groupBegin
  dataLength = Len(base64String)
  For groupBegin = 1 To dataLength Step 4
    Dim numDataBytes, CharCounter, thisChar, thisData, nGroup
    numDataBytes = 3
    nGroup = 0
    For CharCounter = 0 To 3
      thisChar = Mid(base64String, groupBegin + CharCounter, 1)
      If thisChar = "=" Then
        numDataBytes = numDataBytes - 1
        thisData = 0
      Else
        thisData = InStr(1, Base64, thisChar) - 1
      End If
      nGroup = 64 * nGroup + thisData
    Next
    nGroup = Hex(nGroup)
    nGroup = String(6 - Len(nGroup), "0") & nGroup
    ngroupall = ngroupall & nGroup
  Next
 guid2oid = "{" & _
   				  Mid(ngroupall,7,2)&Mid(ngroupall,5,2)&Mid(ngroupall,3,2)&Mid(ngroupall,1,2)& "-" & _
   				  Mid(ngroupall,11,2)&Mid(ngroupall,9,2) &"-"& _
   				  Mid(ngroupall,15,2)&Mid(ngroupall,13,2)&"-"& _
   				  Mid(ngroupall,17,2)&Mid(ngroupall,19,2)&"-"& _
   				  Mid(ngroupall,21,12)&"}"
End Function
Sub sw(label As String)
'uncomment below for benchmarking
 If mtime=0 Then mtime=Timer
 Debug.Print Round(Timer - mtime, 2) & "   :   " & Round(Timer - dtime, 2) & "      :" & label
 dtime = Timer
End Sub
Ao common.mmbas

From ActivityOwnerWiki

Views

Personal tools

Navigation

Search

Toolbox
