' ' Global declarations ' ' ' Programming options ' Option Compare Database Option Explicit ' ' Hardwired limits ' Public Const intMaxGen As Integer = 1000 Public Const intMaxH As Integer = 20 Public Const intMaxK As Integer = 20 ' ' Default files ' Public Const strTXTFile As String = "Family.txt" Public Const strXLSFile As String = "Family.xls" Public Const strGEDFile As String = "Family.ged" ' ' Control variables ' Public blnRoot As Boolean Public strFmt As String Public intFile As Integer ' ' Type definitions ' Public Type udtPerson PerID As String Scion As Integer NumH As Integer Head(intMaxH) As Integer End Type ' Public Type udtFamily Wed As Boolean Him As Integer Her As Integer NumK As Integer Kid(intMaxK) As Integer End Type ' ' End of global declarations ' Function WriteTree(bln0 As Boolean, strID As String) ' ' Writes family tree for nominated person to nominated output format file ' 27 Jan 2020 ' Dim strDir As String, strFile As String Dim db1 As Database, rs1 As Recordset Dim intRec As Integer, intGen As Integer Dim strGen As String ' blnRoot = bln0 ' If strID Like "" Then If blnRoot Then strID = InputBox("Specify family root head ID", "Write tree", "Kingdon06.1.2.2.2") Else strID = InputBox("Specify family tree head ID", "Write tree", "Kingdon01") End If End If ' If strID Like "" Then End End If ' strFmt = InputBox("Specify output format (txt or xls)", "Write tree", "txt") ' If strFmt Like "txt" Then intRec = 0 intGen = 0 strGen = "" strDir = strTrimPath(Access.Application.CurrentDb.NAME) strFile = strTXTFile intFile = FreeFile Open (strDir & strFile) For Output As intFile ElseIf strFmt Like "xls" Then intRec = 1 intGen = 1 strGen = "" strDir = strTrimPath(Access.Application.CurrentDb.NAME) strFile = strXLSFile Excel.Workbooks.Add Excel.Sheets.Add Excel.ActiveSheet.NAME = "Family" Excel.Sheets("Family").Activate Else End End If ' Set db1 = CurrentDb Set rs1 = db1.OpenRecordset("SELECT * FROM People WHERE (People.PerID='" & strID & "');") If Not rs1.EOF Then If strFmt Like "txt" Then Print #intFile, strGen & strSpice(strID) ElseIf strFmt Like "xls" Then Excel.Cells(intRec, intGen) = strSpice(strID) End If Call WriteGens(db1, intRec, intGen, strGen, strID) End If rs1.Close db1.Close ' If strFmt Like "txt" Then Close intFile ElseIf strFmt Like "xls" Then Excel.ActiveWorkbook.SaveAs (strDir & strFile) Excel.ActiveWorkbook.Close End If MsgBox ("File " & strFile & " created") ' ' End of WriteTree ' End Function Sub WriteGens(db1 As Database, intRec As Integer, intGen0 As Integer, strGen0 As String, strID0 As String) ' ' Recursively writes related generations of nominated person to txt or xls ' 24 Aug 2019 ' Dim rs1 As Recordset Dim intGen As Integer Dim strGen As String Dim strID As String ' intGen = intGen0 + 1 strGen = strGen0 & "," ' If blnRoot Then Set rs1 = db1.OpenRecordset("SELECT Relations.Subject AS NextGen FROM Relations INNER JOIN People ON Relations.Subject = People.PerID WHERE (Relations.Has='Child' Or Relations.Has='Adoptee') And (Relations.Object='" & strID0 & "') ORDER BY People.Male;") Else Set rs1 = db1.OpenRecordset("SELECT Relations.Object as NextGen FROM Relations WHERE (Relations.Has='Child' Or Relations.Has='Adoptee') And (Relations.Subject='" & strID0 & "') ORDER BY Relations.RelSeq;") End If If Not rs1.EOF Then rs1.MoveFirst Do Until rs1.EOF intRec = intRec + 1 strID = rs1![NextGen] If strFmt Like "txt" Then Print #intFile, strGen & strSpice(strID) ElseIf strFmt Like "xls" Then Excel.Cells(intRec, intGen) = strSpice(strID) End If Call WriteGens(db1, intRec, intGen, strGen, strID) rs1.MoveNext Loop End If rs1.Close ' ' End of WriteGens ' End Sub Function strTrimPath(strPath As String) As String ' ' Trims filename from full path ' From FAST ' Dim strEndChar As String Dim lngStrLen As Long ' If strPath <> "False" Then lngStrLen = Len(strPath) strEndChar = Right$(strPath, 1) Do Until lngStrLen < 1 Or strEndChar Like "\" lngStrLen = lngStrLen - 1 strPath = Left$(strPath, lngStrLen) strEndChar = Right$(strPath, 1) Loop strTrimPath = strPath Else strTrimPath = "C:\" End If ' ' End of strTrimPath ' End Function Function strSpice(strID As String) As String ' ' Returns a text string identifying a nominated person and their spouse(s) ' 12 Feb 2019 ' Dim strQuery As String Dim db1 As Database, rs1 As Recordset Dim strB As String, strD As String Dim blnBD As Boolean Dim intNumS As Integer, intS As Integer ' Set db1 = CurrentDb ' strQuery = "SELECT * FROM People WHERE (People.PerID='" & strID & "');" Set rs1 = db1.OpenRecordset(strQuery) rs1.MoveFirst strSpice = CStr("[" & rs1![Mnemonic] & "] " & rs1![GivenNames] & " " & rs1![Surname]) strB = "" strD = "" blnBD = False If rs1![Birth] <> "" Then strB = CStr(Right$(rs1![Birth], 4)) blnBD = True End If If rs1![Death] <> "" Then strD = CStr(Right$(rs1![Death], 4)) blnBD = True End If If blnBD Then strSpice = strSpice & " (" & strB & "-" & strD & ")" End If rs1.Close ' strQuery = "SELECT COUNT(*) as Total FROM Relations WHERE (Relations.Has='Spouse') And (Relations.Subject='" & strID & "');" Set rs1 = db1.OpenRecordset(strQuery) intNumS = rs1![Total] rs1.Close ' If intNumS > 0 Then strQuery = "SELECT Relations.RelSeq, People.* FROM Relations INNER JOIN People ON Relations.Object = People.PerID WHERE (Relations.Has='Spouse') AND (Relations.Subject='" & strID & "') ORDER BY Relations.RelSeq;" Set rs1 = db1.OpenRecordset(strQuery) rs1.MoveFirst For intS = 1 To intNumS strSpice = strSpice & CStr(" m" & rs1![RelSeq] & " [" & rs1![Mnemonic] & "] " & rs1![GivenNames] & " " & rs1![Surname]) strB = "" strD = "" blnBD = False If rs1![Birth] <> "" Then strB = CStr(Right$(rs1![Birth], 4)) blnBD = True End If If rs1![Death] <> "" Then strD = CStr(Right$(rs1![Death], 4)) blnBD = True End If If blnBD Then strSpice = strSpice & " (" & strB & "-" & strD & ")" End If rs1.MoveNext Next intS rs1.Close End If ' db1.Close ' ' End of strSpice ' End Function Function FindRel() ' ' Finds the relationship between two people X and Y ' 27 Jan 2020 ' Dim db1 As Database, rs1 As Recordset Dim strX As String, strY As String, strIDHoF As String Dim blnMale As Boolean, blnCompare As Boolean Dim intX As Integer, intY As Integer Dim intNumX As Integer, intNumY As Integer Dim intGX As Integer, intGY As Integer Dim intG As Integer, intGHoF As Integer Dim intGenXHoF As Integer, intGenYHoF As Integer Dim intMaxPeople As Integer Dim strIDX() As String, strIDY() As String Dim intGenX() As Integer, intGenY() As Integer ' strX = InputBox("Specify ID of person X", "Find relation between X and Y", "Kingdon01") strY = InputBox("Specify ID of person Y", "Find relation between X and Y", "Kingdon06.1.2.2.2") If ((strX Like "") Or (strY Like "")) Then End End If ' Set db1 = CurrentDb Set rs1 = db1.OpenRecordset("SELECT COUNT(*) as Total FROM People;") intMaxPeople = rs1![Total] rs1.Close Set rs1 = db1.OpenRecordset("SELECT * FROM People WHERE People.PerID = '" & strX & "';") rs1.MoveFirst blnMale = rs1![Male] rs1.Close db1.Close ' ReDim strIDX(intMaxPeople) ReDim strIDY(intMaxPeople) ReDim intGenX(intMaxPeople) ReDim intGenY(intMaxPeople) ' intNumX = 1 intNumY = 1 strIDX(intNumX) = strX strIDY(intNumY) = strY intGenX(intNumX) = 0 intGenY(intNumY) = 0 ' Call AddGens(strIDX(intNumX), intGenX(intNumX), strIDX(), intGenX(), intNumX) Call AddGens(strIDY(intNumY), intGenY(intNumY), strIDY(), intGenY(), intNumY) ' strIDHoF = "" intGenXHoF = intMaxGen intGenYHoF = intMaxGen intGHoF = intMaxGen blnCompare = False ' For intX = 1 To intNumX strX = strIDX(intX) For intY = 1 To intNumY strY = strIDY(intY) If (strX = strY) Then intGX = intGenX(intX) intGY = intGenY(intY) intG = intGX + intGY If intG < intGHoF Then strIDHoF = strX intGenXHoF = intGX intGenYHoF = intGY intGHoF = intG End If blnCompare = True End If Next intY Next intX ' If blnCompare Then MsgBox (strRel(intGenXHoF, intGenYHoF, blnMale)) Call WriteTree(False, strIDHoF) Else MsgBox ("Blood relationship not established using available data") End If ' ' End of FindRel ' End Function Sub AddGens(strID As String, intGen As Integer, strArr() As String, intArr() As Integer, intNum As Integer) ' ' Recursively adds related generations of nominated person to nominated array ' 13 Feb 2019 ' Dim strQuery As String Dim db1 As Database, rs1 As Recordset Dim intNumPar As Integer Dim intP As Integer, intP1 As Integer, intP2 As Integer ' strQuery = "FROM Relations INNER JOIN People ON Relations.Subject = People.PerID WHERE (Relations.Has='Child' Or Relations.Has='Adoptee') And (Relations.Object='" Set db1 = CurrentDb Set rs1 = db1.OpenRecordset("SELECT COUNT(*) as Total " & strQuery & strID & "');") intNumPar = rs1![Total] rs1.Close ' If intNumPar > 0 Then Set db1 = CurrentDb Set rs1 = db1.OpenRecordset("SELECT * " & strQuery & strID & "') ORDER BY People.Male;") rs1.MoveFirst For intP = 1 To intNumPar intNum = intNum + 1 strArr(intNum) = rs1![Subject] intArr(intNum) = intGen + 1 rs1.MoveNext Next intP rs1.Close End If db1.Close ' intP1 = intNum - intNumPar + 1 intP2 = intNum For intP = intP1 To intP2 Call AddGens(strArr(intP), intArr(intP), strArr(), intArr(), intNum) Next intP ' ' End of AddGens ' End Sub Function strRel(intGenXHoF As Integer, intGenYHoF As Integer, blnMale As Boolean) As String ' ' Returns a text string defining the relationship between X and Y ' 13 Feb 2019 ' Dim intDiffX As Integer, intDiffY As Integer, intDiffRem As Integer Dim strRem As String ' intDiffX = intGenXHoF intDiffY = intGenYHoF ' If ((intDiffX = intMaxGen) Or (intDiffY = intMaxGen)) Then strRel = "Parameter out of range" ElseIf ((intDiffX = 0) And (intDiffY = 0)) Then strRel = "X is the same person as Y" ElseIf ((intDiffX = 0) And (intDiffY > 0)) Then If intDiffY = 1 Then If blnMale Then strRel = "X is the father of Y" Else strRel = "X is the mother of Y" End If ElseIf intDiffY = 2 Then If blnMale Then strRel = "X is the grandfather of Y" Else strRel = "X is the grandmother of Y" End If ElseIf intDiffY = 3 Then If blnMale Then strRel = "X is the great-grandfather of Y" Else strRel = "X is the great-grandmother of Y" End If Else If blnMale Then strRel = "X is the " & strNth(intDiffY - 2) & " great-grandfather of Y" Else strRel = "X is the " & strNth(intDiffY - 2) & " great-grandmother of Y" End If End If ElseIf ((intDiffX > 0) And (intDiffY = 0)) Then If intDiffX = 1 Then If blnMale Then strRel = "X is the son of Y" Else strRel = "X is the daughter of Y" End If ElseIf intDiffX = 2 Then If blnMale Then strRel = "X is the grandson of Y" Else strRel = "X is the granddaughter of Y" End If ElseIf intDiffX = 3 Then If blnMale Then strRel = "X is the great-grandson of Y" Else strRel = "X is the great-granddaughter of Y" End If Else If blnMale Then strRel = "X is the " & strNth(intDiffX - 2) & " great-grandson of Y" Else strRel = "X is the " & strNth(intDiffX - 2) & " great-granddaughter of Y" End If End If ElseIf ((intDiffX = 1) And (intDiffY = 1)) Then If blnMale Then strRel = "X is the brother of Y" Else strRel = "X is the sister of Y" End If ElseIf ((intDiffX = 1) And (intDiffY > 1)) Then If intDiffY = 2 Then If blnMale Then strRel = "X is the uncle of Y" Else strRel = "X is the aunt of Y" End If ElseIf intDiffY = 3 Then If blnMale Then strRel = "X is the great-uncle of Y" Else strRel = "X is the great-aunt of Y" End If Else If blnMale Then strRel = "X is the " & strNth(intDiffY - 2) & " great-uncle of Y" Else strRel = "X is the " & strNth(intDiffY - 2) & " great-aunt of Y" End If End If ElseIf ((intDiffX > 1) And (intDiffY = 1)) Then If intDiffX = 2 Then If blnMale Then strRel = "X is the nephew of Y" Else strRel = "X is the niece of Y" End If ElseIf intDiffX = 3 Then If blnMale Then strRel = "X is the great-nephew of Y" Else strRel = "X is the great-niece of Y" End If Else If blnMale Then strRel = "X is the " & strNth(intDiffX - 2) & " great-nephew of Y" Else strRel = "X is the " & strNth(intDiffX - 2) & " great-niece of Y" End If End If Else intDiffRem = Abs(intDiffX - intDiffY) strRem = "" If intDiffRem > 0 Then strRem = " " & CStr(intDiffRem) & "x removed" End If strRel = "X and Y are " & strNth(intMin(intDiffX, intDiffY) - 1) & " cousins" & strRem End If ' ' End of strRel ' End Function Function strNth(intN As Integer) As String ' ' Returns a text string expressing an integer placement ' 4 Jan 2012 ' Dim strN As String ' strN = CStr(intN) If ((Right$(strN, 1) Like "1") And Not (Right$(strN, 2) Like "11")) Then strNth = strN & "st" ElseIf ((Right$(strN, 1) Like "2") And Not (Right$(strN, 2) Like "12")) Then strNth = strN & "nd" ElseIf ((Right$(strN, 1) Like "3") And Not (Right$(strN, 2) Like "13")) Then strNth = strN & "rd" Else strNth = strN & "th" End If ' ' End of strNth ' End Function Function intMin(intA As Integer, intB As Integer) As Integer ' ' Returns the lesser of two integers ' 26 Dec 2011 ' If intA < intB Then intMin = intA Else intMin = intB End If ' ' End of intMin ' End Function Function WriteGED() ' ' Output database in GED format ' 27 Jan 2020 ' Dim strDir As String, strGED As String Dim db1 As Database, rs1 As Recordset Dim People() As udtPerson, Families() As udtFamily Dim intNumP As Integer, intP As Integer Dim intMaxF As Integer, intNumF As Integer, intF As Integer Dim intH As Integer, intK As Integer Dim intNumPar As Integer, intPa As Integer, intMa As Integer Dim intUnset As Integer Dim blnSet As Boolean ' ' Initialisation ' Set db1 = CurrentDb Set rs1 = db1.OpenRecordset("SELECT COUNT(*) as Total FROM People;") intNumP = rs1![Total] rs1.Close Set rs1 = db1.OpenRecordset("SELECT COUNT(*) as Total FROM Relations;") intMaxF = rs1![Total] rs1.Close ' ReDim People(intNumP) ReDim Families(intMaxF) intUnset = intMaxF + 5 ' intP = 0 Set rs1 = db1.OpenRecordset("SELECT * FROM People;") rs1.MoveFirst Do Until rs1.EOF intP = intP + 1 With People(intP) .PerID = rs1![PerID] .Scion = intUnset .NumH = 0 For intH = 1 To intMaxH .Head(intH) = intUnset Next intH End With rs1.MoveNext Loop rs1.Close ' For intF = 1 To intMaxF With Families(intF) .Wed = False .Him = intUnset .Her = intUnset .NumK = 0 For intK = 1 To intMaxK .Kid(intK) = intUnset Next intK End With Next intF ' ' Every married couple is a family (happy or otherwise) ' NB1 All marriages are between a man and a woman ' NB2 Relations lists each marriage twice, alternating Subject & Object (with potentially different RelSeq entries, since these refer to the Subject alone) ' intF = 0 Set rs1 = db1.OpenRecordset("SELECT Relations.* FROM Relations INNER JOIN People ON Relations.Subject = People.PerID WHERE (Relations.Has='Spouse') AND (People.Male=True) ORDER BY Relations.Subject, Relations.RelSeq;") rs1.MoveFirst Do Until rs1.EOF intF = intF + 1 intPa = intPerID(rs1![Subject], People(), intNumP) intMa = intPerID(rs1![Object], People(), intNumP) With Families(intF) .Wed = True .Him = intPa .Her = intMa End With With People(intPa) .NumH = .NumH + 1 .Head(.NumH) = intF End With With People(intMa) .NumH = .NumH + 1 .Head(.NumH) = intF End With rs1.MoveNext Loop rs1.Close intNumF = intF ' ' For each person, find their parents, if in database ' Then assign each such child to a family, in sequence: Married couple; Father; Mother ' For intP = 1 To intNumP ' For each person ... intPa = 0 ' Find their parents, if in database intMa = 0 intNumPar = 0 Set rs1 = db1.OpenRecordset("SELECT * FROM Relations INNER JOIN People ON Relations.Subject = People.PerID WHERE (Relations.Has='Child' OR Relations.Has='Adoptee') AND (Relations.Object='" & People(intP).PerID & "');") If Not rs1.EOF Then rs1.MoveFirst Do Until rs1.EOF If rs1![Male] Then intPa = intPerID(rs1![Subject], People(), intNumP) intNumPar = intNumPar + 1 Else intMa = intPerID(rs1![Subject], People(), intNumP) intNumPar = intNumPar + 1 End If rs1.MoveNext Loop End If rs1.Close ' blnSet = False If intNumPar > 2 Then Stop ' More than 2 parents! If intNumPar = 2 Then intF = 0 Do Until blnSet Or intF > intNumF intF = intF + 1 With Families(intF) If (.Him = intPa) And (.Her = intMa) Then ' Assign to married couple .NumK = .NumK + 1 .Kid(.NumK) = intP People(intP).Scion = intF blnSet = True End If End With Loop End If ' If Not blnSet And intPa > 0 Then ' Father in database, assign to him intF = 0 Do Until blnSet Or intF > intNumF intF = intF + 1 With Families(intF) If (Not .Wed) And (.Him = intPa) Then ' Not his first child outside (database) marriage .NumK = .NumK + 1 .Kid(.NumK) = intP People(intP).Scion = intF blnSet = True End If End With Loop If Not blnSet Then ' First child outside (database) marriage, include as member of new family intNumF = intNumF + 1 intF = intNumF With Families(intF) .Him = intPa .NumK = 1 .Kid(.NumK) = intP End With With People(intPa) .NumH = .NumH + 1 .Head(.NumH) = intF End With People(intP).Scion = intF blnSet = True End If End If ' If Not blnSet And intMa > 0 Then ' Mother in database, assign to her intF = 0 Do Until blnSet Or intF > intNumF intF = intF + 1 With Families(intF) If (Not .Wed) And (.Her = intMa) Then ' Not her first child outside (database) marriage .NumK = .NumK + 1 .Kid(.NumK) = intP People(intP).Scion = intF blnSet = True End If End With Loop If Not blnSet Then ' First child outside (database) marriage, include as member of new family intNumF = intNumF + 1 intF = intNumF With Families(intF) .Her = intMa .NumK = 1 .Kid(.NumK) = intP End With With People(intMa) .NumH = .NumH + 1 .Head(.NumH) = intF End With People(intP).Scion = intF blnSet = True End If End If Next intP ' ' Check that every person features in at least one family ' For intP = 1 To intNumP With People(intP) If (.Scion = intUnset) And (.NumH = 0) Then Stop End With Next intP ' ' The following output script adapted from code in Excel2GEDv094-family.xls ' intFile = FreeFile strDir = strTrimPath(Access.Application.CurrentDb.NAME) Open (strDir & strGEDFile) For Output As intFile ' ' Header ' strGED = "" strGED = strGED + "0 HEAD" & vbCrLf strGED = strGED + "1 SOUR PAF" & vbCrLf strGED = strGED + "2 VERS 5.2.18.0" & vbCrLf strGED = strGED + "2 NAME Personal Ancestral File" & vbCrLf strGED = strGED + "2 CORP The Church of Jesus Christ of Latter-day Saints" & vbCrLf strGED = strGED + "3 ADDR 50 East North Temple Street" & vbCrLf strGED = strGED + "4 CONT Salt Lake City, UT 84150" & vbCrLf strGED = strGED + "4 CONT USA" & vbCrLf strGED = strGED + "1 DEST Other" & vbCrLf strGED = strGED + "1 DATE " & Format(Date, "dd mmm yyyy") & vbCrLf strGED = strGED + "2 TIME " & Format(Time, "hh:mm:ss") & vbCrLf strGED = strGED + "1 SUBM @SUB1@" & vbCrLf strGED = strGED + "1 FILE " & strGEDFile & vbCrLf strGED = strGED + "1 GEDC" & vbCrLf strGED = strGED + "2 VERS 5.5" & vbCrLf strGED = strGED + "2 Form LINEAGE - LINKED" & vbCrLf strGED = strGED + "1 CHAR ASCII" & vbCrLf strGED = strGED + "1 LANG English" & vbCrLf Print #intFile, strGED; ' ' Submission record ' strGED = "" strGED = strGED + "0 @SUB1@ SUBM" & vbCrLf strGED = strGED + "1 NAME Roger Kingdon" & vbCrLf Print #intFile, strGED; ' ' Individual records ' For intP = 1 To intNumP With People(intP) Set rs1 = db1.OpenRecordset("SELECT * FROM People WHERE People.PerID = '" & .PerID & "';") rs1.MoveFirst strGED = "" strGED = strGED + "0 @I" & CStr(intP) & "@ INDI" & vbCrLf strGED = strGED + "1 NAME " & rs1![KnownAs] & "/" & rs1![Surname] & "/" & vbCrLf strGED = strGED + "2 GIVN " & rs1![GivenNames] & vbCrLf strGED = strGED + "2 SURN " & rs1![Surname] & vbCrLf strGED = strGED + "1 SEX " & strSex(rs1![Male]) & vbCrLf If rs1![Birth] <> "" Then strGED = strGED + "1 BIRT" & vbCrLf strGED = strGED + "2 DATE " & "01 JAN " & Right$(rs1![Birth], 4) & vbCrLf End If If rs1![Death] <> "" Then strGED = strGED + "1 DEAT" & vbCrLf strGED = strGED + "2 DATE " & "01 JAN " & Right$(rs1![Death], 4) & vbCrLf End If If .Scion <> intUnset Then strGED = strGED + "1 FAMC @F" & CStr(.Scion) & "@" & vbCrLf End If For intH = 1 To .NumH strGED = strGED + "1 FAMS @F" & CStr(.Head(intH)) & "@" & vbCrLf Next intH ' Omit this and next 3 lines of sheer garbage ' strGED = strGED + "1 CHAN" & vbCrLf ' strGED = strGED + "2 DATE " & Format(Date, "dd mmm yyyy") & vbCrLf ' strGED = strGED + "3 TIME " & Format(Time, "hh:mm:ss") & vbCrLf Print #intFile, strGED; rs1.Close End With Next intP ' ' Family Record ' For intF = 1 To intNumF With Families(intF) strGED = "" strGED = strGED + "0 @F" & CStr(intF) & "@ FAM" & vbCrLf If .Him <> intUnset Then strGED = strGED + "1 HUSB @I" & CStr(.Him) & "@" & vbCrLf End If If .Her <> intUnset Then strGED = strGED + "1 WIFE @I" & CStr(.Her) & "@" & vbCrLf End If ' Omit this and next 2 lines that are inessential and would require a SQL lookup ' strGED = strGED + "1 MARR" & vbCrLf ' strGED = strGED + "2 DATE " & rs1![RelNotes] & vbCrLf For intK = 1 To .NumK strGED = strGED + "1 CHIL @I" & CStr(.Kid(intK)) & "@" & vbCrLf Next intK Print #intFile, strGED; End With Next intF ' ' Trailer ' strGED = "" strGED = strGED + "0 TRLR" & vbCrLf Print #intFile, strGED; ' Close intFile MsgBox ("File " & strGEDFile & " created") ' db1.Close ' ' End of WriteGED ' End Function Function intPerID(PerID As String, People() As udtPerson, intNumP As Integer) As Integer ' ' Returns a person's integer ID ' 15 Feb 2019 ' Dim intP As Integer Dim blnSet As Boolean ' intP = 0 blnSet = False Do Until blnSet Or intP > intNumP intP = intP + 1 If People(intP).PerID Like PerID Then intPerID = intP blnSet = True End If Loop If Not blnSet Then Stop ' ' End of intPerID ' End Function Function strSex(Male As Boolean) As String ' ' Returns a person's sex ' 15 Feb 2019 ' If Male Then strSex = "M" Else strSex = "F" End If ' ' End of strSex ' End Function