Ao common.mmbas

'04Feb2011 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 '04Feb11 -- adapt to MM9 date issues. move setstartdate code into ao_common from mindreader common '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="20110204" 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 Sub setstartdate(ByRef t As Topic, d As Date) 'MindManager 9 behaves strangely with regard to setting start dates. If a due date is present, it will assume a duration 'of 0 days and move the due date to the start date being set. If a start and due date is present, it will move the due date back 'according to the amount the start date is being moved. This function attempts to work around that behavior by checking the state 'of the task prior to adjusting the start date and then adjusting accordingly. ' 'scenarios: '1: no start or due date present '2: only start date present '3: only due date present '4: start and due date present 'for all these scenarios, the easiest strategy is to save the due date, set the start date, and then fix the due date Debug.Print "in setstartdate" Debug.Print "starting conditions:" Debug.Print t.Task.StartDate Debug.Print t.Task.DueDate Dim temp As Date If d=0 And t.Task.StartDate>0 And t.Task.DueDate>0 Then MsgBox "Start Date can not be removed if start date and end date are already specified" End If temp=t.Task.DueDate t.Task.StartDate=d t.Task.DueDate=temp

Debug.Print "Ending conditions" Debug.Print t.Task.StartDate Debug.Print t.Task.DueDate End Sub