<%[@ IncludeFile "Code/Util.vbs" ]%> <%[@ IncludeFile "Code/Lang.vbs" ]%> <%[@ IncludeFile "Code/IEForm.vbs" ]%> Initialize Report Generator

This file initializes various data structures for this report.  You are welcome to remove this file from the configuration file if feel you don't need it, or write extra code to include new features to your report.  This file is never copied to the destination report, so here is a good place to include your comments and personal notes while you are designing your report.

To view the code, please use a normal text editor such as Notepad or switch to the "HTML Code" view.

 

<%[ ' The idea of the file Init.htm is to show how to use of the Session object. ' The presence of the Init.htm file is a good example of structured programming ' by having initialization code in a common place. strTitle = ReportGenerator.document.Title If (strTitle = "") Then Report.LogWarning "Title Missing! Click on the ""Document"" tab to set a title to your genealogy report." ' Use the default title from the language dictionary strTitle = Dic("Title") End If Session("Title") = strTitle ' Store the report title in the session variable, so it can be accessed from anywhere. Dim strXmlDom, strVersion, oError, strXml, strGlobal, ich, oMatches, oMatch, oSubMatches, oSubMatch, oRegExp_XML ' Check for appropriate version of MS Scripting If (ScriptEngineMajorVersion + (ScriptEngineMinorVersion / 10)) < 5.5 Then Report.LogError "Error: This Report Skin requires Windows Script version 5.5 or above -" & vbNewline & _ "Please install the latest version from the Microsoft Download Center." End If ' Use MS XML Parser to get Custom Tags from GenoPro Xml Set oRegExp_XML = New RegExp oRegExp_XML.Global = True oRegExp_XML.IgnoreCase = True strXmlDom = Array("Msxml2.DOMDocument.6.0","msxml2.DOMDocument.5.0","msxml2.DOMDocument.4.0","msxml2.DOMDocument.3.0","msxml2.DOMDocument", "Microsoft.XMLDOM") On Error Resume Next For Each strVersion in strXmlDom Set oXmlDoc = CreateObject(strVersion) If Err.Number=0 Then Exit For Err.Clear Next If Err.Number <> 0 Then Report.LogError "Unable to load an ActiveX control for MS XML Parser. " & Err.Number & ": " & Err.Description On Error Goto 0 strXml = ReportGenerator.document.GetTextXml oRegExp_XML.Pattern="&#([0-8]|1[124-9]|2[0-9]|3[01]);" Set oMatches = oRegExp_XML.Execute(strXml) If oMatches.Count > 0 Then Report.LogError "Error: The following fields contain invalid XML entities i.e. in range � -  but excluding valid entities , and " & vbNewline & _ "Custom Tag data including Config Parameters in Document Tags will not be processed" strPrevTag = "" For Each oMatch in oMatches ich = InstrRev(strXml,"<",oMatch.FirstIndex) strTag = Mid(strXml, ich, Instr(oMatch.FirstIndex, strXml, "<") - ich) If strTag <> strPrevTag Then Report.LogWarning strTag strPrevTag = strTag Next End If ich = Instr(strXml, "") - ich) oRegExp_XML.Pattern="" Set oMatches = oRegExp_Xml.Execute(strGlobal) oRegExp_XML.Pattern = "\.[^_a-z]" For Each oMatch in oMatches Set oSubMatches = oRegExp_XML.Execute("." & oMatch.SubMatches(0)) If oSubMatches.Count > 0 Then strTag = "." & oMatch.SubMatches(0) For Each oSubMatch In oSubMatches strTag = Replace(strTag, oSubMatch.Value, "._" & Mid(oSubMatch.Value, 2)) Next Report.LogError "Error Invalid Custom Tag '" & oMatch.SubMatches(0) & "' : tag names must start with a letter or an underscore." & vbNewline & _ "Tag should be renamed using the Tag Editor e.g. '" & oMatch.SubMatches(0) & "' renamed to '" & Mid(strTag, 2) & "' or tag deleted if not required." End If Next oRegExp_XML.Pattern = "^((Start|End)?Date)|^((Birth|Birth.Baptism|Death|Death.Funerals|Death.Disposition|Divorce|Marriage|Publication)?\.Date)\." For Each oMatch in oMatches Set oSubMatches = oRegExp_XML.Execute(oMatch.SubMatches(0)) If oSubMatches.Count > 0 Then strTag = oSubMatches.Item(0).Value strTag = Replace(oMatch.SubMatches(0), strTag, Left(strTag, Len(strTag)-1) & "_") Report.LogError "Error Custom Tag '" & oMatch.SubMatches(0) & "' is invalid as it is subordinate to a GenoPro Date field, Dates may be reported incorrectly." & vbNewline & _ "Tag should be renamed using the Tag Editor e.g. '" & oMatch.SubMatches(0) & "' renamed to '" & strTag & "' or tag deleted if not required." End If Next oXmlDoc.loadXml strXml Set oError = oXmlDoc.parseError If oError.errorCode <> 0 Then Report.LogError "Error attempting to parse GenoPro XML data: " & oError.reason & _ " on line " & oError.line & ":" & vbNewline & " " & oError.srcText & vbNewline & _ "Custom Tag data including Config Parameters in Document Tags will not be processed" End If oXmlDoc.setProperty "SelectionLanguage", "XPath" ' Now load Dictionary into MS XML parser to get acces to non-standard attributes e.g. G1, G2 etc. Dim oXmlDic, fOk, strXmlDic Set oXmlDic = CreateObject(strVersion) On Error Resume Next strXmlDic = ReportGenerator.FileGetText("Dictionary.xml") If Err.Number = 0 Then oXmlDic.LoadXml strXmlDic Else ' pre version 2.0.0.6 Report.LogWarning "Using pre 2.0.0.6 Dictionary handler" fOk = oXmlDic.Load(ReportGenerator.PathSkin & "Dictionary.xml") End If On Error Goto 0 Set oError = oXmlDic.parseError If oError.errorCode <> 0 Then Report.LogError "Warning: Unable to parse Dictionary: " & oError.reason & _ " on line " & oError.line & ":" & vbNewline & " " & oError.srcText & vbNewline & _ "Some extended Dictionary elements & attributes will not be available" Set g_oDicRepGen = Nothing Else Set g_oDicRepGen = oXmlDic.selectSingleNode("/Dictionary/ReportGenerator") oXmlDic.setProperty "SelectionLanguage", "XPath" End If ' store some date format strings from the Dictionary in a String Dictionary Object (see also Lang.vbs GetDateFormat) Set oDicCache = Util.NewStringDictionary() Session("DicCache")=oDicCache Session("SKAltDefault") = "" If Not oXmlDic Is Nothing Then Set oNode = oXmlDic.selectSingleNode("/Dictionary/DateFormatting/FmtDateRange") If Not oNode Is Nothing Then For Each strType in Array("Since", "Until", "From", "To") Set oChild = oNode.selectSingleNode("Fmt" & strType & "YMD") If Not oChild Is Nothing Then oDicCache.Add "DR_" & strType & "YMD", oChild.firstChild.text Set oChild = oNode.selectSingleNode("Fmt" & strType & "YM") If Not oChild Is Nothing Then oDicCache.Add "DR_" & strType & "YM", oChild.firstChild.text Set oChild = oNode.selectSingleNode("Fmt" & strType & "Y") If Not oChild Is Nothing Then oDicCache.Add "DR_" & strType & "Y", oChild.firstChild.text Set oChild = oNode.selectSingleNode("Fmt" & strType & "MD") If Not oChild Is Nothing Then oDicCache.Add "DR_" & strType & "MD", oChild.firstChild.text Next Set oChild = oNode.selectSingleNode("FmtFromAndTo") If Not oChild Is Nothing Then oDicCache.Add "DR_FromAndTo", oChild.firstChild.text End If Set oNode = oXmlDic.selectSingleNode("/Dictionary/SearchKeywords/AltDefault") If Not oNode Is Nothing Then Session("SKAltDefault") = oNode.getAttribute("T") End If ' now create a dialog(ue) to allow user to amend Report Parameters. Dim oDialog, oForm, oGroup, oShell, oTable, oRow, OCell, oData, oSelect, oDiv, i, j, k, strParam, strValue, strType, arrOption, nResponse, oParameters, arrSelect(50), arrText(50), sCnt, tCnt, nSize, nMax, btnOk, btnCancel, fFormChanged Set oShell = CreateObject("WScript.Shell") Set oParameters = Util.NewStringDictionary() sCnt = 0 ' Select/Option params tCnt = 0 ' Text params If Not oXmlDic Is Nothing Then Set oNode = oXmlDic.selectSingleNode("/Dictionary/ParameterDescriptions") Set g_oGlobal = oXmlDoc.selectSingleNode("/GenoPro/Global") nResponse = oShell.Popup(Dic("ParametersAsk"), 0, ReportGenerator.SkinName, 36 + &H40000) If Not oNode Is Nothing And nResponse = 6 Then Report.LogWarning Dic("ParametersFormLoad") Set oDialog = New IEForm Set oForm = oDialog.Form oDialog.Title = ReportGenerator.SkinName Set oDiv = oDialog.Division(oForm,"left") oDialog.SetText oDiv, Dic("HeaderConfigParameters") oDialog.LineBreak oDiv oDialog.LineBreak oDiv For i = 0 to oNode.childNodes.length - 1 ' skip comment node Set oChild = oNode.childNodes(i) If oChild.nodeType = 1 Then ' element node (i.e. ignore any comment nodes) Set oGroup = oDialog.Group(oForm, oChild.getAttribute("T")) Set oTable = oDialog.Table(oGroup, "0", "center") For j = 0 to oChild.childNodes.length - 1 Set oParam = oChild.childNodes(j) Set oRow = oDialog.Row(oTable) Set oCell = oDialog.Cell(oRow, "55%", "right") Set oData = oDialog.SetText(oCell, oParam.getAttribute("T")) strType = oParam.getAttribute("Type") strParam = oParam.nodeName strValue = GetParameter(strParam) k = 1 strOption = oParam.getAttribute("O" & k) Set oCell = oDialog.Cell(oRow, "45%", "left") If Not IsNull(strOption) Then Set arrSelect(sCnt) = oDialog.Selection(oCell) arrSelect(sCnt+1) = strParam Do While strOption <> "" arrOption = split(strOption, ":") Set oData = oDialog.SetOption(arrSelect(sCnt), arrOption(0), arrOption(1), arrOption(0) = strValue) k = k + 1 strOption = oParam.getAttribute("O" & k) Loop sCnt = sCnt + 2 Else arrText(tCnt+1) = strParam nSize = oParam.getAttribute("Size") + 0 If IsNull(strType) Then Set arrText(tCnt) = oDialog.SetField(oCell, "text", strValue, Util.IfElse(nSize = 0, 40, nSize), Util.IfElse(nSize = 0, 1024, nSize)) Else Set arrText(tCnt) = oDialog.SetField(oCell, strType, strValue, Util.IfElse(nSize = 0, 30, nSize), Util.IfElse(nSize = 0, 1024, nSize)) End If tCnt = tCnt + 2 End If Next End If Next Set oDiv = oDialog.Division(oForm,"right") oDialog.LineBreak oDiv Set btnOk = oDialog.SetField(oDiv, "button", Dic("Ok"), Len(Dic("Ok")), Len(Dic("Ok"))) oDialog.SetText oDiv, " " Set btnCancel = oDialog.SetField(oDiv, "button", Dic("Cancel"), Len(Dic("Cancel")), Len(Dic("Cancel"))) oDialog.Show = True On Error Resume Next ReportGenerator.Sleep 100 ' see if we are running 2.0.0.6 or above If Err.Number = 0 Then ' yes we are Do Until oDialog.IsClicked(btnOk) Or oDialog.IsClicked(btnCancel) If Err.Number <> 0 Then Report.LogWarning Dic("ParametersAbandoned") Exit Do End If ReportGenerator.Sleep 1000 Loop Else ' pre version 2.0.0.6 Report.LogWarning "Using pre 2.0.0.6 form wait" Err.Clear nResponse = oShell.Popup(Dic("ParametersAmend"), 0, ReportGenerator.SkinName, 64 + &H40000) End If fFormChanged = (Err.Number = 0) And Not oDialog.IsClicked(btnCancel) oDialog.Show = False on Error Goto 0 If fFormChanged Then ' Place amended and unchanged parameters into StringDictionary For i = 0 To sCnt - 1 Step 2 oParameters.Add arrSelect(i + 1), oDialog.GetOption(arrSelect(i)) ' Report.LogWarning arrSelect(i + 1) & "=" & oDialog.GetOption(arrSelect(i)) Next For i = 0 To tCnt - 1 Step 2 oParameters.Add arrText(i + 1), oDialog.GetField(arrText(i)) ' Report.LogWarning arrText(i + 1) & "=" & oDialog.GetField(arrText(i)) Next End If Set oDialog = Nothing ' remove the form End If End If Dim arrGeneralSettings(17) Dim today, locale locale = GetLocale() SetLocale("en-gb") today = Date arrGeneralSettings(0) = Day(today) & " " & MonthName(Month(today), True) & " " & Year(today) SetLocale(locale) ' The following are used by StrPossessiveProperNoun, StrLocativeProperNoun & StrDateSpan respectively, which in turn all call StrSubstititute ' Create array of regular expressions for possessive proper noun conversion (see StrPossessiveProperNoun function in Lang.vbs) arrGeneralSettings(1) = split(Replace(Dic("PossessiveProperNoun"),"=",":"),":") ' Create array of regular expressions for Place preposiiton exceptions e.g. French au Le Mans => au Mans arrGeneralSettings(2) = split(Replace(Dic("LocativeProperNoun") & "(.*)=$1:","=",":"),":") ' Create array of regular expressions for Date Span phrase conversion e.g. French jusqu'en 12 mai 1968 => jusqu'au 12 mai 1968 arrGeneralSettings(16) = split(Replace(Dic("ConvertDateSpan") & "(.*)=$1:","=",":"),":") ' Create a general use RegExp object Set oRegEx = New RegExp oRegEx.IgnoreCase = True Set eSpace = New RegExp eSpace.Global = True eSpace.Pattern = "\s+" Set arrGeneralSettings(3) = oRegEx Set arrGeneralSettings(4) = eSpace Set arrGeneralSettings(14) = oXmlDoc.selectSingleNode("/GenoPro/Global") Set arrGeneralSettings(17) = g_oDicRepGen arrGeneralSettings(15) = Util.FormatPhrase("{0}[-{1}]",LCase(ReportGenerator.SkinLanguage), LCase(GetParameter("LangHtmlCulture"))) arrGeneralSettings(5) = (GetParameter("fUseTreeIndexes") = "Y") arrGeneralSettings(6) = (GetParameter("fHideFamilyDetails") = "Y") arrGeneralSettings(7) = (GetParameter("fHideNameTreeIndex") = "Y") arrGeneralSettings(8) = (GetParameter("fJoinPlaceNames") = "Y") arrGeneralSettings(9) = (GetParameter("fJoinSourceCitationNames") = "Y") arrGeneralSettings(10) = (GetParameter("fCollapseNotes") = "Y") arrGeneralSettings(11) = (GetParameter("fCollapseReferences") = "Y") arrGeneralSettings(12) = GetParameter("cTocExpand") + 0 arrGeneralSettings(13) = GetParameter("StyleSheet") Session("GeneralSettings") = arrGeneralSettings Dim arrPictureSettings(9) strImgSize = GetParameter("PictureSizeLarge") arrPictureSettings(0) = Util.GetWidth(strImgSize) arrPictureSettings(1) = Util.GetHeight(strImgSize) strImgSize = GetParameter("PictureSizeSmall") arrPictureSettings(2) = Util.GetWidth(strImgSize) arrPictureSettings(3) = Util.GetHeight(strImgSize) arrPictureSettings(4) = 0 strPicturePadding = GetParameter("PicturePadding") If (strPicturePadding <> "") Then arrPictureSettings(4) = strPicturePadding + 0 ' Convert the string to integer End If arrPictureSettings(5) = (GetParameter("fHidePictureName") = "Y") arrPictureSettings(6) = (GetParameter("fShowPictureDetails") = "Y") Dim nPictureInterval nPictureInterval = GetParameter("PictureInterval") + 0 If nPictureInterval < 1000 Or nPictureInterval > 10000 Then Report.LogError "Config.xml parameter 'PictureSlider' must be in range 1000 - 10000 (milliseconds)" If nPictureInterval < 1000 Then nPictureInterval = 1000 If nPictureInterval > 10000 Then nPictureInterval = 10000 arrPictureSettings(7) = (-30+(30-9)*((10000 - nPictureInterval)/(10000-1000))) & "" arrPictureSettings(8) = (GetParameter("fUsePictureThumbnails") = "Y") arrPictureSettings(9) = (GetParameter("fUsePictureId") = "Y") Session("PictureSettings") = arrPictureSettings Dim arrMapSettings(9) arrMapSettings(0) = (GetParameter("GoogleMapsApiKey")) arrMapSettings(1) = (GetParameter("GoogleMaps") = "Y") arrMapSettings(2) = (GetParameter("fGoogleMapsLink") = "Y") arrMapSettings(3) = (GetParameter("fGoogleMapsOverview") = "Y") arrMapSettings(4) = (GetParameter("GoogleMapsZoom")) + 0 arrMapSettings(5) = (GetParameter("GoogleMapsType")) + 0 arrMapSettings(6) = Util.GetWidth( GetParameter("GoogleMapsSmall")) arrMapSettings(7) = Util.GetHeight(GetParameter("GoogleMapsSmall")) arrMapSettings(8) = Util.GetWidth( GetParameter("GoogleMapsLarge")) arrMapSettings(9) = Util.GetHeight(GetParameter("GoogleMapsLarge")) Session("MapSettings") = arrMapSettings Dim arrSvgSettings(1) arrSvgSettings(0) = (GetParameter("fSvgExpandFrame") = "Y") arrSvgSettings(1) = (GetParameter("fSvgZoomExtent") = "Y") Session("SvgSettings") = arrSvgSettings Dim arrTimelineSettings(5) arrTimelineSettings(0) = (GetParameter("Timelines") = "Y") arrTimelineSettings(1) = GetParameter("TimelineMinEventsIndividual") + 0 arrTimelineSettings(2) = GetParameter("TimelineMinEventsFamily") + 0 arrTimelineSettings(3) = (GetParameter("TimelineShowDuration") = "Y") arrTimelineSettings(4) = (GetParameter("TimelineContemporary") = "Y") arrTimelineSettings(5) = (GetParameter("TimelineWrapEvents") = "Y") Session("TimelineSettings") = arrTimelineSettings Dim cnt, strLast, oDate, strName, strShort, strTagFull, srTagFormal, strTagKnownAs, strTagShort, strTagAlternative ' Initialise Tags for Name formats strTagFull = GetParameter("TagNameFull") srTagFormal = GetParameter("TagNameFormal") strTagKnownAs = GetParameter("TagNameKnownAs") strTagShort = GetParameter("TagNameShort") strTagAlternative = GetParameter("TagNameAlternative") Session("NameTags") = Array(strTagFull, strTagFormal, strTagKnownAs, strTagShort, strTagAlternative) InitGlobalVariables ' Initialise Name Dictionary lookups if required. Dim oNameDicPlace, oNameDicAlternative, oNameDicRoot, oNameDicPossessive, oNameDicLocative, oNameDicJob, strPlace, strJob strNameDic=GetParameter("LangNameDictionary") strTarget = ReportGenerator.SkinLanguage If strNameDic <> "" Then strNames = GetParameter("LangNames") If strNames <> "" And strNames <> strTarget Then Set oNameDicNames = Util.NewNameDictionary oNameDicNames.BuildLookupTable strNameDic, strNames, strTarget Else Set oNameDicNames = Nothing End If Session("oNameDicNames") = oNameDicNames strPlace = GetParameter("LangPlace") If strPlace <> "" And strPlace <> strTarget Then Set oNameDicPlace = Util.NewNameDictionary oNameDicPlace.BuildLookupTable strNameDic, "P." & strPlace, "P." & strTarget Else Set oNameDicPlace = Nothing End If strJob = GetParameter("LangOccupation") If strJob <> "" And strJob <> strTarget Then Set oNameDicJob = Util.NewNameDictionary oNameDicJob.BuildLookupTable strNameDic, "O." & strJob, "O." & strTarget Else Set oNameDicJob = Nothing End If strAlt = GetParameter("LangAlternative") If strAlt <> "" And strAlt <> strTarget Then Set oNameDicAlternative = Util.NewNameDictionary oNameDicAlternative.BuildLookupTable strNameDic, strTarget, strAlt Else Set oNameDicAlternative = Nothing End If If GetParameter("LangBaseNameLoookup") <> "" Then Set oNameDicRoot = Util.NewNameDictionary oNameDicRoot.BuildLookupTable strNameDic, strTarget, strTarget & "_B" Else Set oNameDicRoot = Nothing End If If GetParameter("LangPossessiveLoookup") <> "" Then Set oNameDicPossessive = Util.NewNameDictionary oNameDicPossessive.BuildLookupTable strNameDic, strTarget, strTarget & "_P" Else Set oNameDicPossessive = Nothing End If If GetParameter("LangLocativeLoookup") <> "" Then Set oNameDicLocative = Util.NewNameDictionary oNameDicLocative.BuildLookupTable strNameDic, "P." & strTarget, "P." & strTarget & "_L" Else Set oNameDicLocative = Nothing End If End If ' The following code generates a complete list of all the individuals ' found in the report. If an individual has an empty name, then ' its href value is set to an empty string so the report generator ' can skip those individuals. ' The list of all individuals is stored in an "ObjectRepertory". ' The first level is the letter of the alphabet, the second level ' is the last name, and finally the individuals. ' This repertory is stored in the Session object so it can be ' accessed by other pages. Set oRepertoryIndividuals = Util.NewObjectRepertory ' Global repertory ' Store the repertory into the Session object Session("oRepertoryIndividuals") = oRepertoryIndividuals Set oRepertoryNoLastName = Util.NewObjectRepertory ' Repertory for the individuals without a last name Session("oRepertoryNoLastName") = oRepertoryNoLastName ' Use a string dictionary to count the number of individuals starting with a given letter of the alphabet ' A string dictionary is much faster and takes less memory than the object repertory Set oStringDictionaryFirstChar = Util.NewStringDictionary() Session("oStringDictionaryFirstChar") = oStringDictionaryFirstChar ' Use a string dictionary to count the frequency of each last name. ' A string dictionary is much faster than the object repertory for counting strings Set oStringDictionaryNames = Util.NewStringDictionary() Session("oStringDictionaryNames") = oStringDictionaryNames Set collectionIndividuals = Util.NewDataSorter() cnt = 0 For Each i in Individuals ' Create some extra 'Properties' for each individual i.Session("NameFull") = StrNameTranslate(i.TagValue(strTagFull), oNameDicNames, False) i.Session("NameFormal") = StrNameTranslate(i.TagValue(srTagFormal), oNameDicNames, False) i.Session("NameKnownAs") = StrNameTranslate(i.TagValue(strTagKnownAs), oNameDicNames, False) strName = StrNameTranslate(i.TagValue(strTagShort), oNameDicNames, False) i.Session("NameShort") = strName i.Session("NamePossessive") = StrPossessiveProperNoun(strName, oNameDicPossessive) Dim strPart, arrParts, strTrans strName = "" If strTagAlternative <> "" Then strName = StrNameTranslate(i.TagValue(strTagAlternative), oNameDicAlternative, True) i.Session("NameAlternative") = Dic.FormatPhrase("PhNameAlternative", i.Session("NameFull"), strName) strName = StrNameTranslate(Util.FirstNonEmpty(i.Name.Last, i.Name.Last2), oNAmeDicNames, False) i.Session("NameLast") = strName If Not oNameDicRoot Is Nothing Then strName = oNameDicRoot(strName) End If i.Session("NameRoot") = strName i.Session("Hlink") = StrHtmlHyperlink(i) i.Session("HlinkNN") = StrHtmlHyperlinkNN(i) Set oDate = i.Birth.Date If oDate.ToStringNarrative = "" Then Set oDate = i.Birth.Baptism.Date ' collectionIndividuals.Add i, Util.StrStripAccentsUCase(Util.StrStripPunctuation(Trim(strLast))), i.Name.First, i.Name.Middle, oDate.Year, oDate.Month, oDate.Day collectionIndividuals.Add i, Util.StrStripAccentsUCase(Util.StrStripPunctuation(Trim(i.Session("NameRoot")))), StrNameTranslate(i.Name.First, oNameDicNames, False), StrNameTranslate(i.Name.Middle, oNameDicNames, False), oDate.Year, oDate.Month, oDate.Day, Util.StrStripAccentsUCase(Util.StrStripPunctuation(Trim(i.Session("NameLast")))) Next collectionIndividuals.SortByKey For Each i In collectionIndividuals.ToGenoCollection ' Keep only the individuals having a name and some data (ie, DataLevel > 1) strName = i.Session("NameFull") 'If (strName <> "" AND i.DataLevel > 1) Then If (strName <> "") Then iCount = iCount + 1 strNameLast = i.Session("NameLast") strNameRoot = i.Session("NameRoot") If isPrivate(i) Then strTemp = i.Href i.Href = g_strPrivateFolder & strTemp End If If (strNameRoot <> "") Then oStringDictionaryNames.Add strNameRoot If strNameLast <> strNameRoot Then strName = oStringDictionaryNames.KeyValue(strNameRoot) If Not Instr("/" & strName & "/", "/" & strNameLast & "/") > 0 Then oStringDictionaryNames.KeyValue(strNameRoot) = strName & "/" & strNameLast End If End If ' Get the first letter of the individual strFirstChar = Util.StrGetFirstChar(Util.StrStripAccentsUCase(Util.StrStripPunctuation(Trim(strNameRoot)))) oStringDictionaryFirstChar.Add strFirstChar If (strFirstChar <> "") Then Set oRepertoryFirstChar = oRepertoryIndividuals.AddObjectRepertory(strFirstChar) oRepertoryFirstChar.Add strNameRoot, i Else ' Add the individual to this special repertory oRepertoryNoLastName.Add strName, i End If Else ' Prevent any hyperlink to this individual because it has no name or not enough data i.Href = "" End If Next Session("IndividualsCount") = iCount ' Now, loop through each letter of the alphabet to determine how many individuals are present ' under each letter of the alphabet ' Store the formatted string in the second key (o.Object(1)) For Each o In oRepertoryIndividuals strFirstChar = o.Key Set oRepertoryFamilies = o.Object(0) o.Add Util.FormatString("({}, {})", Dic.PlurialCount("Family", oRepertoryFamilies.Count), Dic.PlurialCount("Individual", oStringDictionaryFirstChar.KeyCounter(strFirstChar))) Next ' Sort the dictionary from the largest to the smallest number. This dictionary is used to generate ' the meta description and display the most popular family names oStringDictionaryNames.SortByCounter oStringDictionaryNames.Reverse For Each f in Families f.Session("Name") = StrFamilyName(f) Next ' The following code stores addiitonal Properties for Places ' in the Place Session object. Since places are used everywhere in ' the report, a good place to initialize those variables is ' in the file Init.htm. ' For Each p in Places p.Session("NameShort") = StrPlaceTranslate(p.Name) p.Session("NameFull") = JoinPlaceNames(p, p.Session("NameShort"), true) p.Session("LocativeRaw") = JoinPlaceNames(p, StrLocativeProperNoun(p, oNameDicLocative), True) ' used by StrHtmlHyperlink() p.Session("Locative") = Replace(Replace(p.Session("LocativeRaw"), "[", ""), "]", "") p.Session("Hlink") = StrHtmlHyperlinkPlace(p) p.Session("HlinkLocative") = StrHtmlHyperlink(p) If p.City <> "" Then p.Session("City") = StrPlaceTranslate(p.City) If p.State <> "" Then p.Session("State") = StrPlaceTranslate(p.State) If p.County <> "" Then p.Session("County") = StrPlaceTranslate(p.County) If p.Country <> "" Then p.Session("Country") = StrPlaceTranslate(p.Country) Next For Each s in SourcesAndCitations s.Session("Hlink") = StrHtmlHyperlink(s) Next For Each o in Occupations If Not oNameDicJob Is Nothing Then o.Session("Title") = oNameDicJob(o.Title) Else o.Session("Title") = o.Title End If Next ' Create ObjectRepertory for rings/chains of Hyperlinks Set oHyperlinkRings = Util.NewObjectRepertory Session("oHyperlinkRings") = oHyperlinkRings ' Create index for entries in the above Repertory Set oHyperlinkRingIndex = Util.NewStringDictionary() Session("oHyperlinkRingIndex")=oHyperlinkRingIndex ' now build the Repertory and Index For Each o In AllIndividuals ' include hyperlinks If o.hyperlink.internal ="Y" Then If o.IndividualInternalHyperlink.ID <> "" Then ' its the link only oHyperlinkRings.Add o.IndividualInternalHyperlink.ID, o oHyperlinkRingIndex.Add o.ID, oHyperlinkRings.KeyCounter(o.IndividualInternalHyperlink.ID)-1 Else ' it's the source oHyperlinkRings.Add o.ID, o oHyperlinkRingIndex.Add o.ID, oHyperlinkRings.KeyCounter(o.ID)-1 End If End If Next ' Create object repertories to hold Social Relationships indexed by Individual. Set oRepertoryEntity1 = Util.NewObjectRepertory ' key is source entity Session("oRepertoryEntity1") = oRepertoryEntity1 Set oRepertoryEntity2 = Util.NewObjectRepertory ' key is target entity Session("oRepertoryEntity2") = oRepertoryEntity2 For Each r in SocialRelationships if r.entity1.Class = "Individual" Then oRepertoryEntity1.Add r.entity1.ID, r if r.entity2.Class = "Individual" Then oRepertoryEntity2.Add r.entity2.ID, r Next For Each r in EmotionalRelationships if r.Entity1.Class = "Individual" Then oRepertoryEntity1.Add r.Entity1.ID, r if r.Entity2.Class = "Individual" Then oRepertoryEntity2.Add r.Entity2.ID, r Next ' now create an ObjectRepertory with Dictionaries of each set of Custom Tags present together ' with the 'DialogLayout' groupings of each by accessing the GenoPro XML data via MS XMLDOM Dim Layout, strDesc, strTag, strPrevTag, strTags, strPrivate, strSubTag, strSubTags Set oCustomTagRepertory = Util.NewObjectRepertory strPrivate = Dic("Private") ' allows some tags to be excluded from the report. ' build the Custom Tag Repertory. ' ------------------------------- ' The key of each entry is the object class, e.g. Individual, Family, Place etc. ' the 1st object, object(0), is a string dictionary that provides a lookup of tag description from the custom tag name, i.e. the TagData elements ' the 2nd & subsequent objects are string arrays that hold Custom Tag 'Dialog Layout' information as follows: ' element 0 of each array is the name of the 'Dialog Layout' i.e. 'name' attribute ' element 1 of each array is the description of the 'Dialog Layout' i.e. 'description' element ' element 2 onwards are the Custom Tag names in that 'Dialog Layout' i.e. 'tags' element Set oTags = oXmlDoc.selectnodes("/GenoPro/Global/Tags") For Each oTag In oTags oId = oTag.GetAttribute("ID") Set oTagData = oTag.selectnodes("TagData") Set oCustomTagDictionary = Util.NewStringDictionary() For Each oTagDatum In oTagData strTag = oTagDatum.GetAttribute("Name") oCustomTagDictionary.Add strTag, oTagDatum.selectsinglenode("DisplayName").firstChild.text Next ' add the tag dictionary to the repertory entry for this class of GenoPro objects oCustomTagRepertory.Add oId, oCustomTagDictionary ' now add the DiaglogLayouts Set oLayouts = oTag.selectnodes("DialogLayout") For Each oLayout In oLayouts Set oTemp = oLayout.selectsinglenode("Description") If Not oTemp Is Nothing Then strDesc = oTemp.firstChild.text Set oTemp = oLayout.selectsinglenode("Tags") If Not oTemp Is Nothing Then strTags = oTemp.firstChild.text If Left(strDesc,1) <> "_" And (strPrivate = "" Or Instr(strDesc, strPrivate) <> 1) Then Layout = split(oLayout.GetAttribute("Name") & "," & strDesc &"," & strTags,",") For i = 2 to Ubound(Layout) strCustomTagDesc = oCustomTagDictionary.KeyValue(Layout(i)) If Left(strCustomTagDesc,1) ="_" Or (strPrivate <> "" And Instr(strCustomTagDesc, strPrivate) = 1) Then Layout(i) = "" ' blank if private ' Report.LogWarning "Custom Tag '" & strCustomTagDesc & "' in Layout '" & strDesc & "' is marked as system or private and has been excluded" End If Next oCustomTagRepertory.Add oId, Layout Erase Layout Else ' Report.LogWarning "Custom Tag Layout '" & strDesc & "' is marked as system or private and has been excluded" End If strDesc = "" strTags = "" Next Next Set oXmlDoc = nothing Session("oCustomTagRepertory") = oCustomTagRepertory ' Create a Twin 'lookup' repertory Dim t, s, f, oRepertoryTwins Set oRepertoryTwins = Util.NewObjectRepertory Session("oRepertoryTwins") = oRepertoryTwins For Each t in Twins oRepertoryTwins.Add "T" & t.ID, t ' add twin object For each s in t.Siblings oRepertoryTwins.Add "I" & s.ID, "T" & t.ID ' add lookup from each sibling Next If Not Util.IsNothing(t.Family) Then ' t.Family.ID is broken at present (GenoPro 2.0 beta 18c), it returns twin link id instead of family id ' oRepertoryTwins.Add "F" & t.Family.ID, "T" & t.ID ' add lookup from family ' so use this instead oRepertoryTwins.Add "F" & t.Siblings(0).Family.ID, "T" & t.ID ' add lookup from each sibling End If Next ' Create an 'adopted/fostered child' lookup repertory Dim l, oRepertoryNonBio Set oRepertoryNonBio = Util.NewObjectRepertory Session("oRepertoryNonBio") = oRepertoryNonBio For Each l in PedigreeLinks strLink = l.PedigreeLink.ID If strLink = "Adopted" Or strLink = "Foster" And Not l.Child.IsLabel = True Then oRepertoryNonBio.Add UCase(Left(strLink,1)) & l.Family.ID, l oRepertoryNonBio.Add "I" & l.Child.ID, l oRepertoryNonBio.Add "I" & l.Child.ID & "F" & l.Family.ID, l If Not Util.IsNothing(l.Child.Family) Then oRepertoryNonBio.Add "B" & l.Child.Family.ID, l End If Next ' Get a fresh copy of the individuals in order to find the 20 most popular names, ' but this time exclude any names that are private. ' As before, use string dictionaries when appropriate rather than object repertories. iCount = 0 Set oStringDictionaryFirstCharPublic = Util.NewStringDictionary() Set oStringDictionaryNamesPublic = Util.NewStringDictionary() Set oRepertoryIndividualsPublic = Util.NewObjectRepertory Set oRepertoryNoLastNamePublic = Util.NewObjectRepertory Session("oStringDictionaryFirstCharPublic") = oStringDictionaryFirstCharPublic Session("oStringDictionaryNamesPublic") = oStringDictionaryNamesPublic Session("oRepertoryIndividualsPublic") = oRepertoryIndividualsPublic Session("oRepertoryNoLastNamePublic") = oRepertoryNoLastNamePublic For Each i In collectionIndividuals.ToGenoCollection strName = i.Name If (i.Href <> "" And Not isPrivate(i)) Then iCount = iCount + 1 strNameLast = i.Name.Last If strNameLast = "" Then strNameLast = i.Name.Last2 If (strNameLast <> "") Then strNameLast = Ucase(Left(strNameLast,1)) & Lcase(Mid(strNameLast,2)) If Left(strNameLast,2) = "Mc" Then strNameLast = "Mc" & Ucase(Mid(strNameLast,3,1)) & Lcase(Mid(strNameLast,4)) oStringDictionaryNamesPublic.Add strNameLast End If strFirstChar = Util.StrGetFirstChar(Util.StrStripAccentsUCase(Util.StrStripPunctuation(Trim(strNameLast)))) oStringDictionaryFirstCharPublic.Add strFirstChar If (strFirstChar <> "") Then Set oRepertoryFirstCharPublic = oRepertoryIndividualsPublic.AddObjectRepertory(strFirstChar) oRepertoryFirstCharPublic.Add strNameLast, i Else oRepertoryNoLastNamePublic.Add strName, i End If End If Next Session("IndividualsCountPublic") = iCount For Each o In oRepertoryIndividualsPublic strFirstChar = o.Key Set oRepertoryFamilies = o.Object(0) o.Add Util.FormatString("({}, {})", Dic.PlurialCount("Family", oRepertoryFamilies.Count), _ Dic.PlurialCount("Individual", oStringDictionaryFirstChar.KeyCounter(strFirstChar))) Next oStringDictionaryNamesPublic.SortByCounter oStringDictionaryNamesPublic.Reverse For Each f In Families If (f.Name <> "" And Not f.IsLabel) Then strHref = f.Href If strHref <> "" And isPrivate(f) Then f.Href = g_strPrivateFolder & strHref End If End If Next ' Create an index of picture paths by picture id. and also an index of any image maps. Set oPicIndex = Util.NewObjectRepertory() Session("oPicIndex")=oPicIndex Set oPicMaps = Util.NewStringDictionary() Session("oPicMaps")=oPicMaps For Each p in Pictures If Instr(p.Path.Report,":") > 0 Then ' absolute path oPicIndex.Add p.ID, p.Path.Report oPicIndex.Add p.ID, "" Else ' relative path oPicIndex.Add p.ID, p.Path.Report oPicIndex.Add p.ID, "../" End If If CustomTag(p, "_AreaMap") <> "" Then oPicMaps.Add p.ID, CustomTag(p, "_AreaMap") Next ' Create mapping array for Pedigree Ancestor Charts Dim ChartMap Set ChartMap = Util.NewObjectrepertory ' 0=index position of anscestor marker, 1-(0)=format tags ChartMap.Add 0, Array(6,"" ,"" ,"" ,"" ,"T" ,"fffff") ChartMap.Add 1, Array(5,"" ,"" ,"" ,"T" ,"ffff","" ) ChartMap.Add 2, Array(6,"" ,"" ,"" ,"I" ,"L" ,"ffffm") ChartMap.Add 3, Array(4,"" ,"" ,"T" ,"fff","" ,"" ) ChartMap.Add 4, Array(6,"" ,"" ,"I" ,"I" ,"T" ,"fffmf") ChartMap.Add 5, Array(5,"" ,"" ,"I" ,"L" ,"fffm","" ) ChartMap.Add 6, Array(6,"" ,"" ,"I" ,"" ,"L" ,"fffmm") ChartMap.Add 7, Array(3,"" ,"T","ff","" ,"" ,"" ) ChartMap.Add 8, Array(6,"" ,"I","I" ,"" ,"T" ,"ffmff") ChartMap.Add 9, Array(5,"" ,"I","I" ,"T" ,"ffmf","" ) ChartMap.Add 10, Array(6,"" ,"I","I" ,"I" ,"L" ,"ffmfm") ChartMap.Add 11, Array(4,"" ,"I","L" ,"ffm","" ,"" ) ChartMap.Add 12, Array(6,"" ,"I","" ,"I" ,"T" ,"ffmmf") ChartMap.Add 13, Array(5,"" ,"I","" ,"L" ,"ffmm","" ) ChartMap.Add 14, Array(6,"" ,"I","" ,"" ,"L" ,"ffmmm") ChartMap.Add 15, Array(2,"T","f","" ,"" ,"" ,"" ) ChartMap.Add 16, Array(6,"I","I","" ,"" ,"T" ,"fmfff") ChartMap.Add 17, Array(5,"I","I","" ,"T" , "fmff","" ) ChartMap.Add 18, Array(6,"I","I","" ,"I" ,"L" ,"fmffm") ChartMap.Add 19, Array(4,"I","I","T" ,"fmf","" ,"" ) ChartMap.Add 20, Array(6,"I","I","I" ,"I" ,"T" ,"fmfmf") ChartMap.Add 21, Array(5,"I","I","I" ,"L" ,"fmfm","" ) ChartMap.Add 22, Array(6,"I","I","I" ,"" ,"L" ,"fmfmm") ChartMap.Add 23, Array(3,"I","L","fm","" ,"" ,"" ) ChartMap.Add 24, Array(6,"I","" ,"I" , "" ,"T" ,"fmmff") ChartMap.Add 25, Array(5,"I","" ,"I" ,"T" ,"fmmf","" ) ChartMap.Add 26, Array(6,"I","" ,"I" ,"I" ,"L" ,"fmmfm") ChartMap.Add 27, Array(4,"I","" ,"L" ,"fmm","" ,"" ) ChartMap.Add 28, Array(6,"I","" ,"" ,"I" ,"T" ,"fmmmf") ChartMap.Add 29, Array(5,"I","" ,"" ,"L" ,"fmmm","" ) ChartMap.Add 30, Array(6,"I","" ,"" ,"" ,"L" ,"fmmmm") ChartMap.Add 31, Array(1,"i","" ,"" ,"" ,"" ,"" ) ChartMap.Add 32, Array(6,"I","" ,"" ,"" ,"T" ,"mffff") ChartMap.Add 33, Array(5,"I","" ,"" ,"T" ,"mfff","" ) ChartMap.Add 34, Array(6,"I","" ,"" ,"I" ,"L" ,"mfffm") ChartMap.Add 35, Array(4,"I","" ,"T" ,"mff","" ,"" ) ChartMap.Add 36, Array(6,"I","" ,"I" ,"I" ,"T" ,"mffmf") ChartMap.Add 37, Array(5,"I","" ,"I" ,"L" ,"mffm","" ) ChartMap.Add 38, Array(6,"I","" ,"I" ,"" ,"L" ,"mffmm") ChartMap.Add 39, Array(3,"I","T","mf","" ,"" ,"" ) ChartMap.Add 40, Array(6,"I","I","I" ,"" ,"T" ,"mfmff") ChartMap.Add 41, Array(5,"I","I","I" ,"T" ,"mfmf","" ) ChartMap.Add 42, Array(6,"I","I","I" ,"I" ,"L" ,"mfmfm") ChartMap.Add 43, Array(4,"I","I","L" ,"mfm","" ,"" ) ChartMap.Add 44, Array(6,"I","I","" ,"I" ,"T" ,"mfmmf") ChartMap.Add 45, Array(5,"I","I","" ,"L" ,"mfmm","" ) ChartMap.Add 46, Array(6,"I","I","" ,"" ,"L" ,"mfmmm") ChartMap.Add 47, Array(2,"L","m","" ,"" ,"" ,"" ) ChartMap.Add 48, Array(6,"" ,"I","" ,"" ,"T" ,"mmfff") ChartMap.Add 49, Array(5,"" ,"I","" ,"T" ,"mmff","" ) ChartMap.Add 50, Array(6,"" ,"I","" ,"I" ,"L" ,"mmffm") ChartMap.Add 51, Array(4,"" ,"I","T" ,"mmf","" ,"" ) ChartMap.Add 52, Array(6,"" ,"I","I" ,"I" ,"T" ,"mmfmf") ChartMap.Add 53, Array(5,"" ,"I","I" ,"L" ,"mmfm","" ) ChartMap.Add 54, Array(6,"" ,"I","I" ,"" ,"L" ,"mmfmm") ChartMap.Add 55, Array(3,"" ,"L","mm","" ,"" ,"" ) ChartMap.Add 56, Array(6,"" ,"" ,"I" ,"" ,"T" ,"mmmff") ChartMap.Add 57, Array(5,"" ,"" ,"I" ,"T" ,"mmmf","" ) ChartMap.Add 58, Array(6,"" ,"" ,"I" ,"I" ,"L" ,"mmmfm") ChartMap.Add 59, Array(4,"" ,"" ,"L" ,"mmm","" ,"" ) ChartMap.Add 60, Array(6,"" ,"" ,"" ,"I" ,"T" ,"mmmmf") ChartMap.Add 61, Array(5,"" ,"" ,"" ,"L" ,"mmmm","" ) ChartMap.Add 62, Array(6,"" ,"" ,"" ,"" ,"L" ,"mmmmm") Session("ChartMap")=ChartMap ' Finally, the method AbortPage does prevent the file Init.htm to be written ' to the destination report. The AbortPage method does not display ' any error to the user. Report.AbortPage Function GetParameter(strParam) ' get configuration parameter. ' 1st see if value set from Narrative Report dialog (stored in String Dictionary 'oParameters') ' if not, check Document Custom Tag ' otherwise use default from Config.xml Dim oNode, strValue If oParameters(strParam) <> "" Then ' GetParameter = oParameters(strParam) Else strValue = CustomTag(Null, strParam) If strValue <> "" Then GetParameter = strValue Else GetParameter = Report.Parameters(strParam) End If End If End Function Function StrFamilyName(f) ' Fix family name problems in GenoPro ' If one unmarried partner is unknown then the word 'Partner' is used with no Dictionary lookup according to gender or language. ' If one married partner is unknown then the Dictionary entry for _Husband or _Wife is used. This is not always valid if a 'same sex' marriage/civil partnership is involved. ' this code sorts this out. Dim strSufix, strPrefix, strType, strNewType, strG0, strG1, oP0, oP1, strN0, strN1 Set oP0 = f.Parents(0) Set oP1 = f.Parents(1) If f.GotMarried Then strPrefix = "_Spouse" Else strPrefix = "_Partner" strType="Partner" End If If oP0.Name = "" Then strG0 = oP0.Gender.ID strG1 = oP1.Gender.ID strType = Util.IfElse(strG0="M", Dic("_Husband"), Dic("_Wife")) strN0 = Dic.Lookup2(strPrefix & "_" & strG1 & "_" & strG0, strPrefix) strN1 = oP1.Session("NameFull") ElseIf oP1.Name = "" Then strG0 = oP0.Gender.ID strG1 = oP1.Gender.ID strType = Util.IfElse(strG1="M", Dic("_Husband"), Dic("_Wife")) strN1 = Dic.Lookup2(strPrefix & "_" & strG0 & "_" & strG1, strPrefix) StrN0 = oP0.Session("NameFull") Else StrN0 = oP0.Session("NameFull") strN1 = oP1.Session("NameFull") End If strFamilyName = Dic.FormatString("_FmtHusbandAndWife", StrN0, strN1) End Function Function StrLocativeProperNoun(p, oNameDic) ' return 'locative' case of noun as: preposition[name]postposition where 'preposition/postposition may be empty but must include spaces where required ' e.g. 'in [Hogwarts]' Dim strName, strName1, strPrefix, strGender, fPlural, strAttribute, strPrefixID strName = StrPlaceTranslate(p.Name) If Not oNameDic Is Nothing Then 'first use NameDictionary Lookup for exceptions strName1 = oNameDic.Lookup(strName) If strName1 <> strName Then 'exception found StrLocativeProperNoun = Util.IfElse(Instr(strName1,"[") > 0, strName1, "[" & strName1 & "]") Exit Function End If End If ' otherwise get standard prefix and then try replacement via regular expression in Dictionary 'LocativeProperNoun' entry On Error Resume Next strGender = p.Name.Gender.ID On Error Goto 0 If strGender = "" Then strGender = CustomTag(p,"Name.Gender") fPlural = LCase(CustomTag(p, "Name.Plural")) = "y" If fPlural Then strAttribute = "P" Else strAttribute = "T" End If strPrefixID = p.Prefix.ID If strPrefixID = "_" Then ' i.e. setting strPrefix = "" ElseIf strPrefixID <> "" Then strPrefix = Util.FirstNonEmpty(StrDicPeekAttribute("PlacePrefix_" & strPrefixID & "_" & strGender, strAttribute), StrDicPeekAttribute("PlacePrefix_" & strPrefixID, strAttribute), p.Prefix) Else ' i.e. 'automatic' setting strPrefix = Util.FirstNonEmpty(StrDicPeekAttribute("PlacePrefix_" & p.Category.ID & "_" & strGender, strAttribute), StrDicPeekAttribute("PlacePrefix_" & p.Category.ID, strAttribute), StrDicAttribute2("PlacePrefixDefault_" & strGender, "PlacePrefixDefault", strAttribute)) End If strName=Dic.FormatString("_FmtPlaceNarrative", strPrefix, "[" & p.Session("NameFull") & "]") strName = StrSubstitute(strName, g_RegEx_LPN) StrLocativeProperNoun = strName End Function Function StrPossessiveProperNoun(strName, oNameDic) Dim strName1 If Not oNameDic Is Nothing Then 'first use NameDictionary Lookup for exceptions strName1 = oNameDic.Lookup(strName) If strName1 <> strName Then 'exception found StrPossessiveProperNoun = strName1 Exit Function End If End If ' otherwise try replacement via regular expression in Dictionary 'PossessiveProperNoun' entry StrPossessiveProperNoun = StrSubstitute(strName, g_RegEx_PPN) End Function Function StrPlaceTranslate(strName) Dim arrParts, strPart, strTrans, strTranslated strTranslated = strName If Not oNameDicPlace Is Nothing Then arrParts = split(strName, ",") For Each strPart In arrParts strTrans = oNameDicPlace(Trim(strPart)) If strTrans <> strPart Then strTranslated = Replace(strTranslated, Trim(strPart), strTrans) Next End If StrPlaceTranslate = strTranslated End Function ]%> <%[ ]%>