Dim Type(No,Surname,Name,Nick,Father,Mother,Spouse,Marriage,Sex,Fcod,Mcod,Scod,Gen,Pic,Birth,Death,Prev_N,Town,Country,Misc)DB(2500)
#Region Gedcom
Sub GedExport_Click
WaitCursor(True)
FileOpen(c4,"Gedcom_Export_file_" & source & ".ged",cWrite)
write_header
export
FileClose(c4)
Msgbox("Export Completed to" & CRLF & "Gedcom_Export_file_" & source & ".ged")
WaitCursor(False)
End Sub
Sub write_header
FileWrite(c4,"0 HEAD")
FileWrite(c4,"1 SOUR David Erez Family Tree")
FileWrite(c4,"2 VERS 10")
FileWrite(c4,"2 NAME D Erez")
FileWrite(c4,"3 ADDR 18 AYA st Ramat Hasharon ISRAEL")
FileWrite(c4,"1 DEST")
FileWrite(c4,"1 Date " & DateD & "." & DateM & "." & DateY)
FileWrite(c4,"1 SUBM @S0@")
FileWrite(c4,"1 FILE Family_Export_File_" & source & ".ged")
FileWrite(c4,"1 GEDC")
FileWrite(c4,"2 VERS")
FileWrite(c4,"2 FORM LINEAGE_LINKED")
FileWrite(c4,"1 CHAR UTF-8")
FileWrite(c4,"0 @S0@ SUBM")
FileWrite(c4,"1 NAME D. Erez")
FileWrite(c4,"1 ADDR 18 AYA st Ramat Hasharon ISRAEL")
FileWrite(c4,"2 CONT")
End Sub
Sub export
For i = 2 To dbsize
If db(i).Surname <> "" Then 'individual
FileWrite(c4,"0 @I" & db(i).No & "@ INDI") ' name
FileWrite(c4,"1 NAME " & db(i).Name & " " & db(i).Nick & " /" & db(i).Surname & "/")
FileWrite(c4,"2 GIVN " & db(i).Name)
FileWrite(c4,"2 SURN " & db(i).Surname)
If db(i).Nick <> "" Then FileWrite(c4,"2 NICK " & db(i).Nick)
If db(i).Prev_N <> "" Then
If db(i).Sex = 2 Then
FileWrite(c4,"2 _MARNM " & db(i).Prev_N)
Else
FileWrite(c4,"2 _AKA " & db(i).Prev_N)
End If
End If
' sex, birth and death, place
If db(i).Sex = 1 Then FileWrite(c4,"1 SEX M") Else FileWrite(c4,"1 SEX F")
If db(i).Birth <> "" Then
FileWrite(c4,"1 BIRT")
FileWrite(c4,"2 DATE " & db(i).Birth)
End If
If db(i).Death <> "" Then
FileWrite(c4,"1 DEAT")
FileWrite(c4,"2 DATE " & db(i).Death)
End If
' family connections - children of
If IsNumber(db(i).Fcod) Then
FileWrite(c4,"1 FAMC @F" & db(i).Fcod & "@")
Else
If IsNumber(db(i).Mcod) Then FileWrite(c4,"1 FAMC @F" & db(i).Mcod & "@")
End If
' family connections - spouses
If IsNumber(db(i).Scod) Then
If db(i).Sex = 2 Then
FileWrite(c4,"1 FAMS @F" & db(i).scod & "@")
Else
FileWrite(c4,"1 FAMS @F" & db(i).no & "@")
End If
End If
' town and country
If db(i).Country <> "" Then
st = db(i).Country
FileWrite(c4,"1 ADDR")
If db(i).Town <> "" Then st = st & " " & db(i).Town
FileWrite(c4,"2 CONT " & st)
FileWrite(c4,"2 _NAME n/a")
If db(i).Country <> "" Then FileWrite(c4,"2 CTRY " & db(i).Country)
If db(i).Town <> "" Then FileWrite(c4,"2 CITY " & db(i).Town )
End If
' photo attachment
If db(i).Pic = 1 Then
FileWrite(c4,"1 OBJE")
FileWrite(c4,"2 FORM JPG")
FileWrite(c4,"2 FILE " & AppPath & "\JPG\" & db(i).No & ".jpg")
FileWrite(c4,"2 _SCBK Y")
FileWrite(c4,"2 _PRIM Y")
FileWrite(c4,"2 _TYPE PHOTO")
End If
' text file attachment
fname = AppPath & "\text\" & db(i).no & letter & ".txt"
If FileExist(fname) Then
FileWrite(c4,"1 NOTE @NI" & db(i).No & "@ ")
FileWrite(c4,"0 @NI" & db(i).No & "@ NOTE")
FileOpen(c6,fname,cRead)
st = FileRead(c6)
hdr = "1 CONC "
Do While st <> EOF
Do While StrLength(st) > 60
data = SubString(st,0,60)
FileWrite(c4,hdr & data)
hdr = "1 CONC "
st = SubString(st,60,StrLength(st)-60)
Loop
FileWrite(c4,hdr & st)
st = FileRead(c6)
hdr = "1 CONT "
Loop
FileClose(c6)
End If
' Family creation
If db(i).Sex = 1 AND (IsNumber(db(i).Scod) OR children(i) <> "") Then
FileWrite(c4,"0 @F" & db(i).no & "@ FAM")
FileWrite(c4,"1 HUSB @I" & db(i).no & "@")
If IsNumber(db(i).Scod) Then
FileWrite(c4,"1 WIFE @I" & db(i).Scod & "@")
If db(i).Marriage <> "" Then
FileWrite(c4,"1 MARR")
FileWrite(c4,"2 DATE " & db(i).Marriage)
End If
End If
If children(i) <> "" Then
record() = StrSplit(children(i),",")
For j = 0 To ArrayLen(record()) -1
FileWrite(c4,"1 CHIL @I" & record(j) & "@")
Next
End If
End If
' if only mother with no father
If db(i).Sex = 2 AND IsNumber(db(i).Scod)= False AND children(i) <> "" Then
FileWrite(c4,"0 @F" & db(i).no & "@ FAM")
FileWrite(c4,"1 WIFE @I" & db(i).no & "@")
record() = StrSplit(children(i),",")
For j = 0 To ArrayLen(record()) -1
FileWrite(c4,"1 CHIL @I" & record(j) & "@")
Next
End If
End If
Next
FileWrite(c4,"0 TRLR")
End Sub
#End Region
If there is an existing library that can be converted or adopted to basic4ppc - that would be great, but to build it from scratch...
:BangHead:but to build it from scratch is (to my humble opinion) - a waste of time
Public Type (Tag, Value, FirstSon, NextSibling) Records(0)
Version 0.6 is attached with this feature and also a 'Back' button which can navigate to previously visited keys.2. Enable the jump from inside a record to the refered record (like in the tree of a person you can see his sibling, you should be able to select the record reference and jump to this reference tree).
Sub App_Start
form1.Show
Node1.New1
ParentNode.New1
Tree.New1("form1", ComboBox1.Left, ComboBox1.Height + ComboBox1.Top + 5, form1.Width - 20, 180)
End Sub
Sub Openfile_Click
opendialog1.Show
GEDParser.ParseFile(opendialog1.File)
combobox1.Clear
For i = 0 To GEDParser.htKeys.Count-1 'Add all keys to the ComboBox.
ComboBox1.Add(GEDParser.htKeys.GetKey(i))
Next
ShowKeyTree(ComboBox1.Item(0))
End Sub
We use cookies and similar technologies for the following purposes:
Do you accept cookies and these technologies?
We use cookies and similar technologies for the following purposes:
Do you accept cookies and these technologies?