⇧
Exécuter Function Coopérative - 09/02/2026 10:25:54
#DECLARE($classe : Object; $params : Object)->$numProc : Integer
var $nomProcess; $nomTache : Text
var $data : Object
$numProc:=0
Case of
: (Not(OB Is defined($params; "functionID")))
cs._Trace.me.Créer(-15068; Current method name; "'functionID' n'est pas défini dans $params").LeverException([msgk_event; msgk_log])
: (Value type($params.functionID)#Is text)
cs._Trace.me.Créer(-15068; Current method name; "'$params.functionID' n'est pas un texte").LeverException([msgk_event; msgk_log])
: (Not(OB Is defined($params; "numProcessAppelant")))
cs._Trace.me.Créer(-15068; Current method name; "'numProcessAppelant' n'est pas défini dans $params").LeverException([msgk_event; msgk_log])
: ($params.numProcessAppelant=-1)
$nomTache:=$params.nomTache
$nomProcess:="$ALV_process_"+$nomTache
If (OB Is defined($params; "nomProcess"))
$nomProcess:=$params.nomProcess
End if
// créer le nouveau process
$params.numProcessAppelant:=Current process
$numProc:=New process(Current method name; 0; $nomProcess; $classe; $params; *)
Else
// c'est ok
InitProcess
ProcInProgressNum:=0
ProcInProgressTime:=0
AsynchroProgress:=0
// construire la classe
$data:=$classe.new()
If ($data[$params.functionID]#Null)
// lancer le traitement demandé
$data[$params.functionID]($params)
Else
cs._Trace.me.Créer(-15081; Current method name; "La classe "+$classe.name+" n'est pas de function "+$params.functionID).LeverException([msgk_event; msgk_log])
End if
$numProc:=Current process
End case
⇧
Lire Chemin Icones - 15/10/2025 11:15:17
// renvoyer le chemin de l'icone $1
// la construire si absente : $2 = nom du template, $3 = valeur asociée à l'icone
#DECLARE($chemin : Text; $propriete : Text; $valeur : Text)->$result : Text
var $dossierSource; $dossierDestination; $xPath; $racineXML; $template; $fichier; $dataTexte : Text
var $image : Picture
var $blob : Blob
$result:="" // pas d'icone par défaut
// lire le fichier png $1
$xPath:="chaines/nomDossierImages"
If (Lire Ressource Composant("valeur"; ->$xPath; ->$dossierDestination)=0) // nom du dossier des icones
$fichier:=Folder(fk resources folder).folder($dossierDestination).platformPath // au cas ou
$fichier:=$fichier+$chemin+".png"
If (Test path name($fichier)#Is a document)
$xPath:="chaines/nomDossierTemplates"
If (Lire Ressource Composant("valeur"; ->$xPath; ->$dossierSource)=0) // nom du dossier des templates d'icones
// dans l'ordre (permet de "forcer" une icone avant de la créer
// essayer de lire un fichier XML
$template:=Folder(fk resources folder).folder($dossierSource).file($chemin+".xml").platformPath
If (Test path name($template)=Is a document)
// lire le document
DOCUMENT TO BLOB($template; $blob)
$dataTexte:=BLOB to text($blob; UTF8 text without length)
Else
// essayer de créer le fichier à partir du template $2
// lire le template $2
$template:=Folder(fk resources folder).folder($dossierSource).file($propriete+".txt").platformPath
If (Test path name($template)=Is a document)
// lire le document et traiter les balises
DOCUMENT TO BLOB($template; $blob)
$dataTexte:=BLOB to text($blob; UTF8 text without length)
PROCESS 4D TAGS($dataTexte; $dataTexte; $valeur)
Else
// pas d'icone associée
$dataTexte:=""
End if
End if
If ($dataTexte#"") // on a une structure XML
// lire la structure XML
$racineXML:=DOM Parse XML variable($dataTexte)
// convertir en image
SVG EXPORT TO PICTURE($racineXML; $image; Get XML data source)
// créer le fichier image
WRITE PICTURE FILE($fichier; $image)
DOM CLOSE XML($RacineXML)
End if
End if
End if
// envoyer le chemin $1 (en final n'existe pas forcemént!, exemple cas des font-family)
$result:="File:"+$dossierDestination+Folder separator+$chemin+".png"
End if
⇧
InitProcess - 09/02/2026 10:26:09
Capable de process préemptif
// gestion des erreurs
var ErrorNum : Integer
ErrorNum:=0
ON ERR CALL(Formula(traceHandler).source)
⇧
Modifier Arbre - 09/02/2026 09:30:16
Partagée entre composants et base hôte
// Aiguillage entre "Modifier Modèle AG" et "Modifier BDD_AG"
// $MenuID ID du menu, $ptrParam1 commande {$ptrParam2 valeur de la commande)
// la suite de la commande doit se faire dans le contexte de la base hôte, donc appel du container du sousFormulaire
#DECLARE($MenuID : Integer; $ptrParam1 : Pointer; $ptrParam2 : Pointer)
var $ID; $typeInfo : Text
var $wndNum; $couleur; $IDarbre : Integer
var TexteSaisi : Text
Case of
: ($MenuID=0) //Commande Changer de Modèle)
// changer de modèle (on aurait pu ici ouvrir le sélecteur de fichiers)
Form.Modele:=$ptrParam2->
Form.Commande:=cagk Appliquer Modèle
CALL SUBFORM CONTAINER(ALV sur Modification)
// ici : les commandes dont la valeur doit être saisie
: (($MenuID=121) & (Storage.System.EstExecuteDansHote))
// changer Nmax ascendants
Modifier Arbre(Commande Form Saisie; ->$MenuID)
Form.NmaxAscendance:=Num(TexteSaisi)
Form.Commande:=cagk Construire
CALL SUBFORM CONTAINER(ALV sur Modification)
: (($MenuID=122) & (Storage.System.EstExecuteDansHote))
// changer Nmax descendants
Modifier Arbre(Commande Form Saisie; ->$MenuID)
Form.NmaxDescendance:=Num(TexteSaisi)
Form.Commande:=cagk Construire
CALL SUBFORM CONTAINER(ALV sur Modification)
: ($MenuID=Commande Form Saisie)
Form.titreSaisi:=Localized string(String($ptrParam1->))
Form.texteSaisi:=""
$wndNum:=Open form window("Saisie"; Sheet form window)
DIALOG("Saisie")
TexteSaisi:=Form.texteSaisi*Num(Ok=1)
CLOSE WINDOW
: ($MenuID=373) // sélectionner la valeur du style $ptrParam1
Case of
: ($ptrParam1->="stroke-width")
: (($ptrParam1->="stroke") | ($ptrParam1->="fill"))
// obtenir la couleur
$couleur:=Select RGB color(0; Localized string("4"))
// mettre au format SVG #rrvvbb
$ID:="00"+Replace string(String($couleur; "&x"); "0x"; "")
$ptrParam2->:="#"+Substring($ID; Length($ID)-5; 6)
Modifier Arbre(12; $ptrParam1; $ptrParam2)
: ($ptrParam1->="opacity")
End case
Else
// ici : les commandes de modification du modèle ou de la BDD_AG
Case of
: (Form.EtatProcessus.Params ?? 0)
// modifier le modèle courant de l'arbre
// le parent de "SelectedElementID_SVG" contient le type de l'élément
$ID:=DOM Find XML element by ID(arbreDOM; Form.EtatProcessus.SelectedElementID_SVG)
$ID:=DOM Get parent XML element($ID)
DOM GET XML ATTRIBUTE BY NAME($ID; "typeElement"; $ID)
$typeInfo:=Form.EtatProcessus.SelectedInformationID_SVG
If ($typeInfo="")
// traiter les commandes relatives à un élément :
Case of
: (Count parameters=2)
Modifier Modèle AG($MenuID; ->$ID; $ptrParam1)
: (Count parameters=3)
Modifier Modèle AG($MenuID; ->$ID; $ptrParam1; $ptrParam2)
End case
Else
// traiter les commandes relatives à une information :
// $ID contient l'id d'un objet en BDD et le type de l'info
$typeInfo:=String(Num(Substring($typeInfo; Position("_"; $typeInfo))))
Case of
: (Count parameters=1)
Modifier Modèle AG($MenuID; ->$ID; ->$typeInfo)
: (Count parameters=3)
Modifier Modèle AG($MenuID; ->$ID; ->$typeInfo; $ptrParam1; $ptrParam2)
End case
End if
//-- forcer la mise à jour de tout l'arbre
// v10.3.8 : les BDD externes sont fermées après chaque traitement ; la réouvrir
Fixer Paramètres BDD_AG(Form)
Ouvrir BDD_Externe(Form)
$IDarbre:=Form.IDarbre
Begin SQL
UPDATE cadres SET init_deploiement = FALSE, deployed = FALSE, gauche = 0, haut = 0, init_dessin = FALSE WHERE cadres.arbre = :$IDarbre;
End SQL
// appliquer le modèle modifié et déployer
Form.Commande:=cagk Appliquer Modèle
CALL SUBFORM CONTAINER(ALV sur Modification)
: (Form.EtatProcessus.Params ?? 1)
// modifier uniquement l'élément courant de la BDD_AG
Case of
: (False)
ALERT(Current method name+" : Commande "+String($MenuID)+" modifier la BDD_AG pas faite")
End case
End case
End case
⇧
Bac à sable ARB - 01/08/2026 13:08:54
//Visualiser Arbre Généalogique
//$commande: bit 1 afficher l'AG dans le visualisateur
//$commande: bit 2 créer une image de l'AG
//$commande: bit 4 test SQL
//$commande: bit 29 // test messagerie
//$commande: bit 30 // afficher la console
//$commande: bit 31 // traduction
var $o; $paramsArbre; $EtatProcessus : Object
var $maDate : Date
ARRAY LONGINT($aTab; 0)
ARRAY LONGINT($aTab1; 0)
var $i; $j; $Nmin; $Nmax; $commande
var $c : Collection
var $x : Text
var $result : Boolean
var $ptr : Pointer
InitProcess
ON ERR CALL(Formula(traceHandler).source) // gestion des erreurs
$c:=[30]
//$c.push(1)
$c.push(31)
$commande:=0
For each ($i; $c)
$commande:=$commande ?+ $i
End for each
//var $texte : Text
//var $image : Picture
//$texte:=DOM Parse XML source(Folder("/Applications/4D 20 R8/4D.app/Contents/Resources").file("KeyboardMapping.xml").platformPath)
//SVG EXPORT TO PICTURE($texte; $image; Copy XML data source) // KO Erreur -9926 L'élément référencé est invalide. 4DRT
//SVG EXPORT TO PICTURE($texte; $image; Get XML data source) // KO Erreur -9926 L'élément référencé est invalide. 4DRT
//SVG EXPORT TO PICTURE($texte; $image; Own XML data source) // OK
//var $pict : Picture
//var $texte; $svgRef : Text
//var $dossier : 4D.Folder
//$dossier:=Folder(fk documents folder).folder("test")
//$svgRef:=DOM Parse XML source($dossier.file("structureSVG_ALV.xml").platformPath)
////$svgRef:=SVG_New(500; 200; "Test_composant")
//$x:=SVG_New_circle($svgRef; 100; 100; 50; "black"; "red"; 2)
//DOM EXPORT TO FILE($svgRef; $dossier.file("structureSVG.xml").platformPath)
//$pict:=SVG_SAVE_AS_PICTURE($svgRef; 1)
//SVG EXPORT TO PICTURE($svgRef; $pict; Copy XML data source)
//SVG_SAVE_AS_PICTURE($svgRef; $dossier.file("imageSVG.png").platformPath)
//ABORT
If ($commande ?? 1)
// afficher la structure de l'arbre
$i:=0
InitProcess
If (True)
$i:=952
$Nmin:=2
$Nmax:=1
$j:=CodeEnreg(952; [1])
End if
OB SET($paramsArbre; "IDarbre"; $i)
OB SET($paramsArbre; "IDpersonne"; $j)
OB SET($paramsArbre; "CheminDossierBDD_AG"; Folder(Structure file; fk platform path).parent.parent.platformPath)
OB SET($paramsArbre; "CheminDossierExport"; Folder(fk documents folder).folder("tempo_ALV").folder("_ARBdebug").platformPath)
OB SET($paramsArbre; "nomBDD"; String($i)+"_"+String($Nmin)+"_"+String($Nmax))
//OB FIXER($paramsArbre; "nomBDD"; "Navigation")
OB SET($paramsArbre; "Session_Etat"; 0x0004)
OB SET($paramsArbre; "Session_Etat"; 0x00C4 ?- 6)
OB SET($paramsArbre; "Session_Etat"; 0x00C4 ?+ 6)
OB SET($paramsArbre; "optionsMsg"; [msgk_event])
OB SET($paramsArbre; "Options"; 0x0005)
OB SET($paramsArbre; "NmaxAscendance"; $Nmin; "NmaxDescendance"; $Nmax)
OB SET($paramsArbre; "Modele"; "Test Déploiement.xml")
OB SET($paramsArbre; "Modele"; "Normal.xml")
//OB FIXER($paramsArbre; "Modele"; "Test Redim Reposition tracés.xml")
OB SET($paramsArbre; "SéparateurParamsURL"; "?")
OB SET($paramsArbre; "functionID"; cagk Appliquer Modèle)
OB SET($paramsArbre; "FormatImage"; Truncated non centered)
//OB FIXER($paramsArbre;"FormatImage";Proportionnelle centrée)
OB SET($EtatProcessus; "Params"; 0x0000)
//OB FIXER($EtatProcessus; "Params"; 0x03000001)
// dessiner les connexions et les cadres
OB SET($EtatProcessus; "Params"; 0x0D000008)
// dessiner les cadres
OB SET($EtatProcessus; "Params"; 0x0008)
OB SET($EtatProcessus; "SaisieAutorisée"; True)
OB SET($paramsArbre; "EtatProcessus"; $EtatProcessus)
// debug :
//OB SET($paramsArbre; "Session_Etat"; $paramsArbre.Session_Etat ?+ 8)
//OB SET($paramsArbre.EtatProcessus; "Params"; $paramsArbre.EtatProcessus.Params ?+ 27)
////OB SET($paramsArbre.EtatProcessus; "Params"; $paramsArbre.EtatProcessus.Params ?+ 28)
//SET ASSERT ENABLED(True)
cs.__test.new().Démarrer($paramsArbre)
End if
If ($commande ?? 2)
$i:=0
InitProcess
If (True)
$i:=109
$Nmin:=1
$Nmax:=1
$j:=CodeEnreg(108; [1])
End if
If (False)
$i:=3010
$Nmin:=1
$Nmax:=1
End if
OB SET($paramsArbre; "IDarbre"; $i)
OB SET($paramsArbre; "IDpersonne"; $j)
OB SET($paramsArbre; "NmaxAscendance"; $Nmin)
OB SET($paramsArbre; "NmaxDescendance"; $Nmax)
OB SET($paramsArbre; "NomBDD_AG"; "Session")
OB SET($paramsArbre; "NomBDD_AG"; "test3010")
OB SET($paramsArbre; "NomBDD_AG"; "Arbre_"+String($i)+" n="+String($Nmin)+"-"+String($Nmax))
OB SET($paramsArbre; "StatusHôte"; 0x0004)
OB SET($paramsArbre; "StatusHôte"; 0x00C4)
OB SET($paramsArbre; "Options"; 0x0001)
//OB FIXER($paramsArbre;"Modele";"Test Déploiement.xml")
//OB FIXER($paramsArbre;"Modele";"serveur HTML.xml")
OB SET($paramsArbre; "Modele"; "Normal.xml")
OB SET($paramsArbre; "Commande"; cagk Appliquer Modèle)
//OB FIXER($paramsArbre;"Commande";Déployer AG)
OB SET($EtatProcessus; "Params"; 0x0000)
//OB FIXER($EtatProcessus;"Params";0x03000001)
OB SET($EtatProcessus; "Params"; 0x0D000000)
//OB FIXER($EtatProcessus;"Params";0)
OB SET($EtatProcessus; "SaisieAutorisée"; True)
OB SET($paramsArbre; "EtatProcessus"; $EtatProcessus)
cs.$arbre.new().Imager_AG($paramsArbre)
$x:=$params.arbreXML
End if
If ($commande ?? 4)
If (True)
$i:=952
$Nmin:=2
$Nmax:=1
$j:=CodeEnreg(952; [1])
End if
OB SET($paramsArbre; "IDarbre"; $i)
OB SET($paramsArbre; "IDpersonne"; $j)
OB SET($paramsArbre; "CheminDossierBDD_AG"; Folder(Structure file; fk platform path).parent.parent.platformPath)
OB SET($paramsArbre; "CheminDossierExport"; Folder(fk documents folder).folder("tempo_ALV").folder("_ARBdebug").platformPath)
OB SET($paramsArbre; "nomBDD"; String($i)+"_"+String($Nmin)+"_"+String($Nmax))
OB SET($paramsArbre; "Session_Etat"; 0x0004)
OB SET($paramsArbre; "optionsMsg"; [msgk_event])
OB SET($paramsArbre; "Options"; 0x0005)
OB SET($paramsArbre; "NmaxAscendance"; $Nmin; "NmaxDescendance"; $Nmax)
OB SET($paramsArbre; "Modele"; "Test Déploiement.xml")
//OB FIXER($paramsArbre;"Modele";"Normal.xml")
//OB FIXER($paramsArbre;"Modele";"serveur HTML.xml")
OB SET($paramsArbre; "functionID"; cagk Appliquer Modèle)
OB SET($paramsArbre; "FormatImage"; Truncated non centered)
//OB FIXER($paramsArbre;"FormatImage";Proportionnelle centrée)
OB SET($EtatProcessus; "Params"; 0x0000)
// dessiner les connexions
OB SET($EtatProcessus; "Params"; 0x0D000000)
// dessiner les cadres
OB SET($EtatProcessus; "Params"; 0x0D000008)
OB SET($EtatProcessus; "SaisieAutorisée"; True)
OB SET($paramsArbre; "EtatProcessus"; $EtatProcessus)
$o:=cs.$arbre.new($paramsArbre)
$o.OuvrirBDD_Externe()
ARRAY LONGINT(champINT; 23; 0)
ARRAY REAL(champREAL; 23; 0)
ARRAY BOOLEAN(champBOOL; 23; 0)
// les indices de tableaux sont des constantes du thème TablesBDD_AG
// tous les cadres de l'arbre
Begin SQL
SELECT id, type_element, calque, largeur, hauteur, gauche, haut, init_deploiement, deployed FROM cadres WHERE cadres.arbre = :$i INTO :[champINT{1}], :[champINT{2}], :[champINT{3}], :[champREAL{4}], :[champREAL{5}], :[champREAL{6}], :[champREAL{7}], :[champBOOL{8}], :[champBOOL{9}];
End SQL
$o.FermerBDD_Externe()
End if
If ($commande ?? 29)
$o:=New object("sourceLogs"; ALV Client APP; "wndTitre"; "toto"; "nbrMaxLogs"; 500)
cs.xSDK.EvenementsALV.me.AfficherEditeur($o)
var $trace : cs._Trace
$trace:=cs._Trace.me
$trace.Créer(-16301; Current method name; "texte erreur").LeverException([msgk_event; msgk_log])
Waiting(1)
$trace.Créer(-16320; Current method name; "Cadre "+String(123)+" de type 176 (autre conjoint) : le numLogic ne doit pas être égal à 1").LeverException([msgk_event; msgk_log])
Waiting(1)
$trace.EnvoyerMessages([msgk_event]; "start 0"; Current method name; "dessin terminé, image SVG transmise")
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; "WK start 0"; Current method name; "WK dessin terminé, image SVG transmise"; New object("nomProcess"; Current process name; "numProcess"; Current process))
cs._Trace.me.Créer(-16320; Current method name; "bis repetita").LeverException([msgk_event; msgk_log])
var $heure : Time
$heure:=Create document(Folder(fk documents folder).folder("tempo_ALV").file("test").platformPath)
$heure:=Create document(Folder(fk documents folder).folder("tempo_ALV").file("test").platformPath)
$trace.EnvoyerMessages([msgk_event]; "start 1"; Current method name; "dessin terminé, image SVG transmise")
$trace.EnvoyerMessages([msgk_event]; "start 2"; Current method name; "dessin terminé, image SVG transmise")
End if
If ($commande ?? 30)
// afficher la console de l'application
var $params : Object
$params:=New object
$params.Commande:="Afficher"
$params.sourceLogs:=ALV Client APP
$params.wndTitre:="Logs application ALV"
$params.nbrMaxLogs:=2000
cs.xSDK.EvenementsALV.me.AfficherEditeur($params)
End if
If ($commande ?? 31)
cs.__test.new().ModifierTraduction()
End if
⇧
Lire Ressource Composant - 15/10/2025 11:17:30
Capable de process préemptif
// Lit une ressource de l'application (externe au fichier structure à partir de la version V11)
// $1 = ID ressource, $2 chemin xml, $3 = pointeur sur la ressource renvoyée
#DECLARE($quoi : Text; $xPathPtr : Pointer; $dossierPtr : Pointer; $trucPtr : Pointer)->$result : Integer
var $fichier : 4D.File
var $structureDeDonnées; $RacineXML; $Xpath; $ElementXML; $dataTexte; $ErrorDescription : Text
var $Error; $i : Integer
$Error:=0
$fichier:=Folder(fk resources folder).file("DataARB.xml")
Case of
: (Not($fichier.exists))
$Error:=-16103
$ErrorDescription:="Le fichier <DataARB.xml> n'existe pas dans les ressources du composant"
: (Count parameters<2)
$Error:=-15068
$ErrorDescription:="Le paramètre $2 n'existe pas"
Else
$structureDeDonnées:=""
cs.xSDK.XML.me.LireFichier($fichier; ->$structureDeDonnées)
ok:=0
$RacineXML:=DOM Parse XML variable($structureDeDonnées)
If (ok=1) //l'erreur n'est pas captée par "Gere Erreurs" (?)
DOM GET XML ELEMENT NAME($RacineXML; $Xpath)
$Xpath:="/"+$Xpath
If ($xPathPtr->#"")
$Xpath:=$Xpath+"/"+$xPathPtr->
End if
Case of
: ($quoi="valeur") // value du chemin $2
$ElementXML:=DOM Find XML element($RacineXML; $Xpath)
If (Ok=1) // lire la donnée et la renvoyer
$dataTexte:=""
DOM GET XML ELEMENT VALUE($ElementXML; $dataTexte)
$dossierPtr->:=$dataTexte // tester type de $3...
Else
$Error:=-16314 // élément inexistant dans la structure XML
$ErrorDescription:="La valeur de <"+$xPathPtr->+"> n'existe pas dans la structure XML de "+$fichier.platformPath
End if
: ($quoi="listValeurs") // liste des values des éléments du chemin ID $2
ARRAY TEXT($informations; 0)
$ElementXML:=DOM Find XML element($RacineXML; $Xpath; $informations)
If (ok=1)
ARRAY TEXT($dossierPtr->; Size of array($informations))
For ($i; 1; Size of array($informations))
DOM GET XML ELEMENT VALUE($informations{$i}; $dossierPtr->{$i})
End for
Else
$Error:=-16314 // élément inexistant dans la structure XML
$ErrorDescription:="La liste de valeurs de <"+$xPathPtr->+"> n'existe pas dans la structure XML de "+$fichier.platformPath
End if
: ($quoi="listParams") // liste des couples nom/value des éléments du chemin ID $2
ARRAY TEXT($informations; 0)
$ElementXML:=DOM Find XML element($RacineXML; $Xpath; $informations)
If (ok=1)
ARRAY TEXT($dossierPtr->; Size of array($informations))
ARRAY TEXT($trucPtr->; Size of array($informations))
For ($i; 1; Size of array($informations))
DOM GET XML ELEMENT NAME($informations{$i}; $Xpath)
$ElementXML:=DOM Find XML element($informations{$i}; "name")
DOM GET XML ELEMENT VALUE($ElementXML; $dossierPtr->{$i})
$ElementXML:=DOM Find XML element($informations{$i}; "value")
DOM GET XML ELEMENT VALUE($ElementXML; $trucPtr->{$i})
End for
Else
$Error:=-16314 // élément inexistant dans la structure XML
$ErrorDescription:="La liste de paramètres de <"+$xPathPtr->+"> n'existe pas dans la structure XML de "+$fichier.platformPath
End if
End case
DOM CLOSE XML($RacineXML)
Else
$Error:=-16305
$ErrorDescription:=$fichier.platformPath+" : structure XML inexistante"
End if
End case
cs._Trace.me.Créer($Error; Current method name; $ErrorDescription).LeverException([msgk_event; msgk_log])
$result:=$Error
⇧
Select dans SVG_AG - 15/10/2025 15:00:39
// $commande ID de la commande d'activation
#DECLARE($commande : Text; $ptrElement : Pointer)
var $ID_SVG; $svgElement; $svgInfo; $dataTexte; $valeur; $état : Text
var $i; $j : Integer
Case of
: (Form.EtatProcessus=Null)
// sous formulaire pas encore chargé
: ($commande="SélectionnerElement")
// sélectionner l'élément $ptrElement
Case of
: (Form.EtatProcessus.OverElementID_SVG=Null)
: ($ptrElement->=Form.EtatProcessus.OverElementID_SVG)
Else
// on a changé d'élément
Select dans SVG_AG("DésélectionnerTout")
End case
$svgElement:=DOM Find XML element by ID(arbreDOM; $ptrElement->)
If (ok=1)
DOM SET XML ATTRIBUTE($svgElement; "stroke-opacity"; "1.0") // sélectionner l'élément en cours
// renseigner le nouvel élément
Form.EtatProcessus.OverElementID_SVG:=$ptrElement->
Form.EtatProcessus.SelectedInformationID_SVG:=""
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
SET CURSOR(9000)
End if
: ($commande="AfficherRectInfos")
// afficher le rect des informations de l'élément sélectionné
$svgElement:=DOM Find XML element by ID(arbreDOM; Form.EtatProcessus.OverElementID_SVG)
$svgElement:=DOM Get parent XML element($svgElement)
ARRAY TEXT($ElementXMLlist; 0)
$svgElement:=DOM Find XML element($svgElement; "g/g"; $ElementXMLlist) // list de toutes les infos
For ($i; 1; Size of array($ElementXMLlist))
// chercher le rect de classe "CadreElement"
$svgElement:=DOM Get first child XML element($ElementXMLlist{$i})
Repeat
DOM GET XML ELEMENT NAME($svgElement; $dataTexte)
If ($dataTexte="rect")
// ils ne sont pas tous classés
For ($j; 1; DOM Count XML attributes($svgElement))
DOM GET XML ATTRIBUTE BY INDEX($svgElement; $j; $dataTexte; $valeur)
If ($dataTexte="class")
If ($valeur="CadreElement")
DOM SET XML ATTRIBUTE($svgElement; "visibility"; "visible") // afficher le rect de l'information
End if
End if
End for
End if
$svgElement:=DOM Get next sibling XML element($svgElement)
Until (ok=0) // jusqu`à la fin de la liste
End for
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
: ($commande="SélectionnerInfo")
// sélectionner l'info $ptrElement
Case of
: (Form.EtatProcessus.OverInformationID_SVG=Null)
: ($ptrElement->=Form.EtatProcessus.OverInformationID_SVG)
Else
// on a changé d'information
Select dans SVG_AG("DésélectionnerInfo")
End case
// sélectionner le nouveau
$svgElement:=DOM Find XML element by ID(arbreDOM; $ptrElement->)
DOM SET XML ATTRIBUTE($svgElement; "stroke-opacity"; "1.0") // sélectionner l'information en cours
Form.EtatProcessus.OverInformationID_SVG:=$ptrElement->
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
SET CURSOR(9000)
: ($commande="DésélectionnerInfo")
// désélectionner l'info sélectée
$ID_SVG:=Form.EtatProcessus.OverInformationID_SVG
Select dans SVG_AG("DésélectionnerInfos"; ->$ID_SVG)
: ($commande="DésélectionnerInfos")
// désélectionner $ptrElement
ARRAY TEXT($ElementXMLlist; 0)
If (Is nil pointer($ptrElement)) // -> toutes les informations de l'élément sélecté
Case of
: (Form.EtatProcessus.SelectedElementID_SVG=Null)
: (Form.EtatProcessus.SelectedElementID_SVG="")
Else
$svgElement:=DOM Find XML element by ID(arbreDOM; Form.EtatProcessus.SelectedElementID_SVG)
$svgElement:=DOM Get parent XML element($svgElement)
$svgElement:=DOM Find XML element($svgElement; "g/g"; $ElementXMLlist)
$état:="hidden"
End case
Else // -> l'information sélectée
If ($ptrElement->#"")
$svgElement:=DOM Find XML element by ID(arbreDOM; $ptrElement->)
$svgElement:=DOM Get parent XML element($svgElement)
APPEND TO ARRAY($ElementXMLlist; $svgElement)
$état:="visible"
End if
End if
For ($i; 1; Size of array($ElementXMLlist))
// chercher le rect de classe "CadreElement"
$svgElement:=DOM Get first child XML element($ElementXMLlist{$i})
// il peut y avoir plusieurs ElementXML "rect"
Repeat
DOM GET XML ELEMENT NAME($svgElement; $dataTexte)
If ($dataTexte="rect")
// ils ne sont pas tous classés
For ($j; 1; DOM Count XML attributes($svgElement))
DOM GET XML ATTRIBUTE BY INDEX($svgElement; $j; $dataTexte; $valeur)
Case of
: ($dataTexte="id")
$ID_SVG:=$valeur // mémoriser pour la suite (masquage des ancres)
: ($dataTexte="class")
If ($valeur="CadreElement") // désélectionner l'information
DOM SET XML ATTRIBUTE($svgElement; "stroke-opacity"; "0.3"; "visibility"; $état)
End if
End case
End for
// masquer les ancres
$ID_SVG:=$ID_SVG+"Ancres"
$svgInfo:=DOM Find XML element by ID(arbreDOM; $ID_SVG)
If (ok=1)
DOM SET XML ATTRIBUTE($svgInfo; "visibility"; "hidden") // au cas où
End if
End if
$svgElement:=DOM Get next sibling XML element($svgElement)
Until (ok=0) // jusqu`à la fin de la liste
End for
Form.EtatProcessus.SelectedInformationID_SVG:=""
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
SET CURSOR
: ($commande="SélectionnerAncres")
// afficher les ancres de l'élément sélectionné
$ID_SVG:=$ptrElement->+"Ancres"
$svgElement:=DOM Find XML element by ID(arbreDOM; $ID_SVG)
If (ok=1)
DOM SET XML ATTRIBUTE($svgElement; "visibility"; "visible")
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
End if
: ($commande="DésélectionnerTout")
// désélectionner l'élément
Case of
: (Form.EtatProcessus.OverElementID_SVG=Null)
: (Form.EtatProcessus.OverElementID_SVG="")
Else
$ID_SVG:=Form.EtatProcessus.OverElementID_SVG
cs.$arbre.new().DeSelectionner($ID_SVG)
// masquer les rect info
Select dans SVG_AG("DésélectionnerInfos"; Get pointer(""))
End case
Form.EtatProcessus.OverElementID_SVG:=""
Form.EtatProcessus.SelectedElementID_SVG:=""
Form.EtatProcessus.OverInformationID_SVG:=""
Form.EtatProcessus.SelectedInformationID_SVG:=""
SET CURSOR
End case
⇧
Fixer Paramètres BDD_AG - 15/10/2025 11:19:11
Capable de process préemptif
#DECLARE($params : Object)
// si besoin, installer le dossier de la BDD_AG
Dossiers AG("FixerCheminSQL BDD_AG"; ->$params)
//// chemin du dossier
//$params.cheminDossierBDD:=Dossiers AG("Dossier BDD_AG")
// fixer les paramètres de la structure de la BDD, au cas où besoin de créer la BDD
$params.parametresBDD:=New object
$params.parametresBDD.cheminStructure:=Folder(fk resources folder).folder("Enumérations").file("Structure_BDD_AG.json").platformPath
$params.parametresBDD.structure:=JSON Parse(Document to text($params.parametresBDD.cheminStructure))
⇧
Curseur Busy - 31/01/2026 19:11:20
//******************
//Gère l'affichage de l'avancement d'un process.
//Un process caché doit entretenir 2 variables rendant compte de la progression d(0 à 10000), et ProcInProgressEtat(locatedStrID).
//Un premier process crée le process caché dont le numéro est dans ProcInProgressNum. "curseur busy" est appelé périodiquement pour afficher l'état du process caché dans le formulaire du premier process.
//******************
#DECLARE($type : Integer)
// $1 = bits 24-31 : type curseur
var $gauche; $haut; $droite; $bas : Integer
var ProcInProgressNum; ProcInProgressTime; AsynchroProgress : Integer
Case of
: (Count parameters=0)
// gérer le thermomètre progression
If (ProcInProgressNum>0)
If (Process state(ProcInProgressNum)>=Executing)
// le process "ProcInProgressNum" est en progress
GET PROCESS VARIABLE(ProcInProgressNum; ProcInProgressTime; ProcInProgressTime)
Else
ProcInProgressNum:=0 // arrêter le thermomètre
End if
End if
OBJECT GET COORDINATES(*; "avancement"; $gauche; $haut; $droite; $bas)
If (($droite-$gauche>0) & ($bas-$haut>0))
// un thermomètre existe dans le formulaire courant
OBJECT SET VISIBLE(ProcInProgressTime; ProcInProgressNum>0)
End if
: (Count parameters=1)
If ($type ?? 24) // bit 24 = curseur horaire
If (Is a variable(->AsynchroProgress))
AsynchroProgress:=$1 & 0x0001
OBJECT SET VISIBLE(AsynchroProgress; AsynchroProgress=1)
End if
End if
If ($type ?? 25) // bit 25 = curseur thermomètre
// un seul cas : initialiser les variables
ProcInProgressNum:=0
ProcInProgressTime:=0
OBJECT SET VISIBLE(ProcInProgressTime; False)
End if
End case
⇧
Dossiers AG - 31/05/2025 14:31:03
Capable de process préemptif
//******************
//pas de paramètre : chemin du dossier des BDD_AG
//$1 : paramètres de l'arbre
//******************
// Les documents utilisateurs sont : les BDD_AG créées et les modèles AG.
// Les modèles AG sont dans des dossiers de la base hôte (ou du composant en développement) : ils ne sont pas effacés à la mise à jour du composant dans la base hôte
// Les BDD_AG sont par défaut dans un dossier au même niveau que le dossier des fichiers données de la base hôte (ou du composant en développement). Le dossier par défaut est modifiable via $1
#DECLARE($quoi : Text; $paramsPtr : Pointer)->$result : Text
var $dossier; $fichier; $xPath : Text
Case of
: ($quoi="Dossier Modèles AG")
// renvoyer le chemin du dossier où sont rangées tous les modèles
$fichier:=""
$xPath:="chaines/nomDossierModeles"
If (Lire Ressource Composant("valeur"; ->$xPath; ->$fichier)=0) // nom du dossier des modèles
// le dossier est installée au même niveau que les ressources de la base hôte (ou du composant en développement)
$result:=Folder(fk resources folder).folder($fichier).platformPath
Else
$result:=""
End if
: ($quoi="FixerCheminSQL BDD_AG")
// fixer le nom sql de la BDD AG
// * fixer le dossier de la BDD_AG (données base hôte)
$dossier:=Dossiers AG("Dossier BDD_AG") // par défaut
Case of
// il faut un paramètre
: (Not(OB Is defined($paramsPtr->; "CheminDossierBDD_AG")))
// il faut une donnée
: (Test path name($paramsPtr->CheminDossierBDD_AG)#Is a folder)
Else
// c'est ok on prend
$dossier:=$paramsPtr->CheminDossierBDD_AG
End case
// les BDD_AG sont dans un sous dossier spécifique
$fichier:=""
$xPath:="chaines/nomDossierBDDs_AG"
If (Lire Ressource Composant("valeur"; ->$xPath; ->$fichier)=0) // nom du dossier des BDDs AG
// utiliser ce sous dossier
$dossier:=Folder($dossier).folder($fichier).platformPath
End if
// * fixer le nom de la BDD_AG
$result:=""
If (Not($paramsPtr->nomBDD=Null))
$fichier:=$paramsPtr->nomBDD
Else
$fichier:="AG_"+String($paramsPtr->IDpersonne & 0x00FFFFFF) // nom de la BDD (dossier .4dbase)
End if
// * chemin de la BDD_AG
$fichier:=Folder($dossier).folder($fichier+".4dbase").platformPath+"Arbres_Genealogiques" // nom sql de la BDD"
OB SET($paramsPtr->; "sql_BDDpath"; $fichier)
$result:=$fichier
: ($quoi="Dossier BDD_AG")
// renvoyer le chemin du dossier par défaut où sont rangées toutes les BDD_AG
// le dossier est installée au même niveau que les fichiers données de la base hôte (ou du composant en développement)
$result:=File(Data file).parent.parent.platformPath
End case
⇧
Modifier Modèle AG - 15/10/2025 11:20:04
// $1 = commande; plusieurs cas
// :
// : $2 = typeElement , $3 = ID du template
// : $2 = typeElement , $3 = type Info, $4 = ID du style{, $5 = valeur du style}
#DECLARE($commande : Integer; $typeElementPtr : Pointer; $typeInfoPtr : Pointer; $IDstylePtr : Pointer; $valeurStylePtr : Pointer)->$result : Integer
var $fichier; $dataTexte; $racineXMLmodele; $Xpath; $elementXMLmodele; $racineXML; $elementXML; $ErrorDescription : Text
var $IDmenu; $IDarbre; $error; $dataValue : Integer
$ErrorDescription:=""
// récupérer le modèle de l'arbre
$IDarbre:=paramsArbre.IDarbre
Begin SQL
SELECT modele FROM arbres WHERE id = :$IDarbre INTO :$dataTexte;
End SQL
$racineXMLmodele:=DOM Parse XML variable($dataTexte)
$IDmenu:=$commande
Case of
: ($IDmenu=0) //Commande Ajouter Info) // copier le template $3 de "DataARB.xml" dans le modèle de l'élément du cadre IDBDDcodé = $2
// élémentXML à modifier dans le modèle
$elementXML:=DOM Find XML element by ID($racineXMLmodele; $typeElementPtr->)
DOM GET XML ELEMENT NAME($elementXML; $Xpath)
$Xpath:=$Xpath+"/informationsList"
$elementXMLmodele:=DOM Find XML element($elementXML; $Xpath)
If (ok=0)
$elementXMLmodele:=DOM Create XML element($elementXML; $Xpath)
End if
If (ok=1)
// élément à copier
$fichier:=Get 4D folder(Current resources folder)+"DataARB.xml"
$RacineXML:=DOM Parse XML source($fichier)
$elementXML:=DOM Find XML element by ID($racineXML; $typeInfoPtr->)
$elementXML:=DOM Get first child XML element($elementXML)
If (ok=1)
// copier
$elementXMLmodele:=DOM Append XML element($elementXMLmodele; $elementXML)
$error:=-16311*Num(ok=0)
$ErrorDescription:="Ajout impossible d'une information au modèle"
Else
$error:=-16312
$ErrorDescription:="Element "+String($typeInfoPtr->)+" absent dans le modèle de l'arbre"
End if
Else
$error:=-16313
$ErrorDescription:="template "+$typeElementPtr->+" absent dans le fichier <DataARB.xml>"
End if
DOM CLOSE XML($RacineXML)
: ($IDmenu=372) // modifier la rotation
// $2 contient l'id d'un objet en BDD et le type de l'info
// élémentXML à modifier dans le modèle
$Xpath:="orientation"
$elementXML:=Chercher dans Modèle AG(->$racineXMLmodele; $typeInfoPtr; $typeInfoPtr; "élément"; ->$Xpath)
If ($elementXML#"")
DOM GET XML ELEMENT VALUE($elementXML; $dataTexte)
DOM SET XML ELEMENT VALUE($elementXML; Num($dataTexte)+Num($5->))
End if
: ($IDmenu=204) // redimensionner le cadre
// $2 contient l'id du template, $3 $4 la dimension largeur, hauteur
$elementXMLmodele:=DOM Find XML element by ID($racineXMLmodele; $typeElementPtr->)
DOM GET XML ELEMENT NAME($elementXMLmodele; $Xpath)
$Xpath:=$Xpath+"/deploiement"
$elementXML:=DOM Find XML element($elementXMLmodele; $Xpath+"/largeur")
If (ok=1)
$dataValue:=$typeInfoPtr-> // convertir en entier
DOM SET XML ELEMENT VALUE($elementXML; $dataValue)
End if
$elementXML:=DOM Find XML element($elementXMLmodele; $Xpath+"/hauteur")
If (ok=1)
$dataValue:=$IDstylePtr-> // convertir en entier
DOM SET XML ELEMENT VALUE($elementXML; $dataValue)
End if
: ($IDmenu=303) // déplacer une information
// $2 contient l'id du template, $3 type de l'info, $4 et $5 la position X, Y
$Xpath:="positionX"
$elementXML:=Chercher dans Modèle AG(->$racineXMLmodele; $typeInfoPtr; $typeInfoPtr; "élément"; ->$Xpath)
If ($elementXML#"")
$dataValue:=Num($IDstylePtr->) // convertir en entier
DOM GET XML ELEMENT VALUE($elementXML; $dataTexte)
DOM SET XML ELEMENT VALUE($elementXML; Num($dataTexte)+$dataValue)
End if
$Xpath:="positionY"
$elementXML:=Chercher dans Modèle AG(->$racineXMLmodele; $typeInfoPtr; $typeInfoPtr; "élément"; ->$Xpath)
If ($elementXML#"")
$dataValue:=Num($5->) // convertir en entier
DOM GET XML ELEMENT VALUE($elementXML; $dataTexte)
DOM SET XML ELEMENT VALUE($elementXML; Num($dataTexte)+$dataValue)
End if
: ($IDmenu=304) // supprimer une information
// $2 contient l'Id du template, $3 id de l'info à supprimer
// élémentXML à modifier dans le modèle
$elementXML:=Chercher dans Modèle AG(->$racineXMLmodele; $typeInfoPtr; $typeInfoPtr)
If ($elementXML#"")
DOM REMOVE XML ELEMENT($elementXML)
End if
: ($IDmenu=360) // modifier le format d'une information
// $2 contient l'id d'un template, $3 type de l'info, $4 le nom de l'élément, $5 la valeur
// élémentXML à modifier dans le modèle
$elementXML:=Chercher dans Modèle AG(->$racineXMLmodele; $typeInfoPtr; $typeInfoPtr; "élément"; $IDstylePtr)
If ($elementXML#"")
DOM SET XML ELEMENT VALUE($elementXML; Num($5->))
End if
: ($IDmenu=371) // modifier un style
// rmk : 'normalement' $3 est dans la liste du modèle (sinon, on ne fait rien, pas d'erreur)
// élémentXML à modifier dans le modèle
$elementXML:=Chercher dans Modèle AG(->$racineXMLmodele; $typeInfoPtr; $typeInfoPtr; "style"; $IDstylePtr)
If ($elementXML#"")
$elementXML:=DOM Find XML element($elementXML; "style/value")
DOM SET XML ELEMENT VALUE($elementXML; $5->)
End if
Else
cs._Trace.me.Créer(-16315; Current method name; "le menu "+String($IDmenu)+" n'est pas géré").LeverException([msgk_event; msgk_log])
End case
DOM EXPORT TO VAR($racineXMLmodele; $dataTexte)
Begin SQL
UPDATE arbres SET modele = :$dataTexte WHERE id = :$IDarbre;
End SQL
DOM CLOSE XML($racineXMLmodele)
cs._Trace.me.Créer($Error; Current method name; $ErrorDescription).LeverException([msgk_event; msgk_log])
$result:=$error // renvoyer le résultat
⇧
traceHandler - 30/12/2024 19:45:04
cs._Trace.me.Intercepter()
⇧
Chercher dans Modèle AG - 15/10/2025 11:20:31
Capable de process préemptif
// cherche dans le template $2 de la structure $1, et renvoie l'information de type $3 {, param $4, valeur $5}
#DECLARE($racineXMLmodelePtr : Pointer; $typeElementPtr : Pointer; $typeInfoPtr : Pointer; $quoi : Text; $IDstylePtr : Pointer)->$result : Text
var $dataTexte; $racineXMLmodele; $Xpath; $elementXMLmodele; $racineXML; $elementXML : Text
$result:="" // pas trouvé par défaut
$racineXMLmodele:=$racineXMLmodelePtr->
$elementXML:=DOM Find XML element by ID($racineXMLmodele; $typeElementPtr->)
DOM GET XML ELEMENT NAME($elementXML; $Xpath)
$RacineXML:=DOM Find XML element($elementXML; $Xpath+"/informationsList")
// chercher l'information dont typeInfo = $3
$elementXMLmodele:=DOM Get first child XML element($RacineXML)
Repeat
$elementXML:=DOM Find XML element($elementXMLmodele; "information/typeInfo")
DOM GET XML ELEMENT VALUE($elementXML; $dataTexte)
If ($dataTexte=$typeInfoPtr->) // trouvé
If (Count parameters>3)
Case of
: ($quoi="style")
// chercher le style $5
$RacineXML:=DOM Find XML element($elementXMLmodele; "information/stylesList")
$elementXMLmodele:=DOM Get first child XML element($RacineXML)
Repeat
$elementXML:=DOM Find XML element($elementXMLmodele; "style/name")
DOM GET XML ELEMENT VALUE($elementXML; $dataTexte)
If ($dataTexte=$IDstylePtr->) // trouvé
$result:=$elementXMLmodele
End if
// rmk : on va au bout de la liste, trouvé ou pas trouvé !
$elementXMLmodele:=DOM Get next sibling XML element($elementXMLmodele)
Until (ok=0)
: ($quoi="élément")
$result:=DOM Find XML element($elementXMLmodele; "information/"+$IDstylePtr->)
End case
Else
$result:=$elementXMLmodele
End if
End if
// rmk : on va au bout de la liste, trouvé ou pas trouvé !
$elementXMLmodele:=DOM Get next sibling XML element($elementXMLmodele)
Until (ok=0)
⇧
Ouvrir BDD_Externe - 05/01/2026 17:23:23
Capable de process préemptif
// Ouvrir (ou créer si elle n'existe pas) une BDD externe, via SQL
#DECLARE($form : Object)
var $Error : Integer
var $ErrorDescription; $nomBDD; $sql_BDDpath; $sql_BDDcourantePath; $texte : Text
var $table; $champ : Object
$Error:=-15068
Case of
: (Not(OB Is defined($form; "nomBDD")))
$ErrorDescription:="nomBDD n'est pas défini dans $form"
: (Not(OB Is defined($form; "sql_BDDpath")))
$ErrorDescription:="sql_BDDpath n'est pas défini dans $form"
Else
// ok on a tout
$Error:=0
$nomBDD:=$form.nomBDD
// fixer le nom de la BDD externe ouvrir
$sql_BDDpath:=$form.sql_BDDpath
// lire la BDD externe ouverte
$sql_BDDcourantePath:=""
Begin SQL
SELECT DATABASE_PATH() FROM _USER_SCHEMAS LIMIT 1 INTO :$sql_BDDcourantePath;
End SQL
If (Position("/"; $sql_BDDcourantePath)>0)
$sql_BDDcourantePath:=Convert path POSIX to system($sql_BDDcourantePath)
End if
Case of
: ($sql_BDDpath+".4DB"=$sql_BDDcourantePath)
// déjà ouverte, ne rien faire
: (Test path name($sql_BDDpath+".4DB")=Is a document)
// ouverture d'une BDD $nomBDD existante
Begin SQL
USE DATABASE DATAFILE :$sql_BDDpath;
End SQL
// attention ici on est thread-safe
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; "Process "+Current process name; Current method name; "Ouverture de '"+$sql_BDDpath+"'"; New object("nomProcess"; Current process name; "numProcess"; Current process))
Else
Waiting(30)
// nouvelle BDD externe
//-- créer les fichiers $fichier.4DB et $fichier.4DD
//-- créer / mettre à jour la structure
//-- créer les index
//-- envoyer les requêtes SQL vers la BDD externe
// créer la commande de création de la structure
Case of
: (Not(OB Is defined($form; "parametresBDD")))
$Error:=-15063
$ErrorDescription:="parametresBDD n'est pas défini"
: (Not(OB Is defined($form.parametresBDD; "structure")))
$Error:=-15063
$ErrorDescription:="structure n'est pas défini dans parametresBDD"
: ($form.parametresBDD.structure.length=0)
$Error:=-15063
$ErrorDescription:="structure de parametresBDD est vide"
Else
Begin SQL
CREATE DATABASE IF NOT EXISTS DATAFILE :$sql_BDDpath;
USE DATABASE DATAFILE :$sql_BDDpath;
End SQL
For each ($table; $form.parametresBDD.structure)
// on a une table
Case of
: (Not(OB Is defined($table; "nomTable")))
: (Not(OB Is defined($table; "champs")))
: ($table.champs.length=0)
Else
// ok on a une table et ses champs
$texte:="CREATE TABLE IF NOT EXISTS "+$table.nomTable
// lister les champs
$texte:=$texte+" ("
For each ($champ; $table.champs)
$texte:=$texte+$champ.champ+" "+$champ.type+", "
End for each
// fermer
$texte:=Substring($texte; 1; Length($texte)-2)+");"
End case
Begin SQL
EXECUTE IMMEDIATE :$texte;
End SQL
// id automatique
$texte:="ALTER TABLE "+$table.nomTable+" MODIFY id ENABLE AUTO_INCREMENT;"
Begin SQL
EXECUTE IMMEDIATE :$texte;
End SQL
End for each
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; "Process "+Current process name; Current method name; "Création de '"+$sql_BDDpath+"'"; New object("nomProcess"; Current process name; "numProcess"; Current process))
End case
End case
// Maintenant toutes les requêtes SQL du process sont dirigées vers $sql_BDDpath
End case
cs._Trace.me.Créer($Error; Current method name; $ErrorDescription).LeverException([msgk_event; msgk_log])
⇧
Déplacer Element Arbre - 15/10/2025 11:21:50
#DECLARE($quoi : Text; $textePtr : Pointer; $xPtr : Pointer; $yPtr : Pointer)
var $ID_SVG; $svgElement; $texte : Text
var $déplacementX; $déplacementY; $boutonSouris : Integer
var $largeur; $hauteur : Real
var $EtatProcessus : Object
Case of
// nécessaire en mode interprété
: (Undefined(paramsArbre))
// abandonner
Else
// c'est ok
$EtatProcessus:=paramsArbre.EtatProcessus
Case of
: ($quoi=Sur début déplacement ancre)
// mémoriser le cadreElement ou CadreInformation concerné
$EtatProcessus.MovedID:=$textePtr->
// mémoriser le départ du déplacement
positionX:=MouseX
positionY:=MouseY
: ($quoi=Sur déplacement ancre)
$ID_SVG:=$EtatProcessus.MovedID
If ($ID_SVG#"") // déplacement en cours
// lire le déplacement entre 2 appels
$déplacementX:=MouseX-positionX
$déplacementY:=MouseY-positionY
$svgElement:=DOM Find XML element by ID(arbreDOM; $ID_SVG)
Case of
: ($ID_SVG="@CadreElement@")
// agrandir le cadre
DOM GET XML ATTRIBUTE BY NAME($svgElement; "width"; $largeur)
DOM GET XML ATTRIBUTE BY NAME($svgElement; "height"; $hauteur)
DOM SET XML ATTRIBUTE($svgElement; "width"; $largeur+$déplacementX; "height"; $hauteur+$déplacementY)
// rmk "transform" contient maintenant les nouvelles dimensions du cadre
: ($ID_SVG="@CadreInformation@")
// repositionner le cadre
$svgElement:=DOM Get parent XML element($svgElement) // l'ancre $ID_SVG est dans un groupe
DOM GET XML ATTRIBUTE BY NAME($svgElement; "transform"; $texte)
// ajouter le déplacement à l'attribut translate
Déplacer Element Arbre("EcrireParamsTranslate"; ->$texte; ->$déplacementX; ->$déplacementY)
DOM SET XML ATTRIBUTE($svgElement; "transform"; $texte)
// rmk "transform" contient maintenant la nouvelle position de l'information
End case
// repositionner les ancres
$svgElement:=DOM Find XML element by ID(arbreDOM; $ID_SVG+"Ancres")
DOM GET XML ATTRIBUTE BY NAME($svgElement; "transform"; $texte)
// ajouter le déplacement à l'attribut translate
Déplacer Element Arbre("EcrireParamsTranslate"; ->$texte; ->$déplacementX; ->$déplacementY)
DOM SET XML ATTRIBUTE($svgElement; "transform"; $texte)
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
// repartir de la position courante
positionX:=MouseX
positionY:=MouseY
MOUSE POSITION($déplacementX; $déplacementY; $boutonSouris)
If ($boutonSouris=0)
Déplacer Element Arbre(Sur fin déplacement ancre)
End if
End if
: ($quoi=Sur fin déplacement ancre)
// lire le redimensionnement / déplacement dans l'attribut "transform"
$ID_SVG:=$EtatProcessus.MovedID
$svgElement:=DOM Find XML element by ID(arbreDOM; $ID_SVG+"Ancres")
DOM GET XML ATTRIBUTE BY NAME($svgElement; "transform"; $texte)
$largeur:=0
$hauteur:=0
Déplacer Element Arbre("LireParamsTranslate"; ->$texte; ->$largeur; ->$hauteur)
// appliquer l'écart au modèle
Case of
: ($ID_SVG="@CadreElement@")
Modifier Arbre(204; ->$largeur; ->$hauteur)
: ($ID_SVG="@CadreInformation@")
Modifier Arbre(303; ->$largeur; ->$hauteur)
End case
// arrêter l'espionnage
$EtatProcessus.MovedID:=""
// appels internes
// lecture / écriture des params de "translate"; un peu compliqué : "transform" peut avoir plusieurs commandes
: ($quoi="EcrireParamsTranslate")
// ajouter le déplacement $3 et $4 à "translate" $2
$largeur:=0
$hauteur:=0
Déplacer Element Arbre("LireParamsTranslate"; $textePtr; ->$largeur; ->$hauteur)
// calculer les limites de "translate"
$déplacementX:=Position("translate("; $textePtr->)
$déplacementY:=Position(")"; $textePtr->; $déplacementX)
// extraire le translate
$texte:=Substring($textePtr->; $déplacementX; $déplacementY-$déplacementX+1)
// remplacer l'ancien "translate" par le nouveau
$textePtr->:=Replace string($textePtr->; $texte; "translate("+String($largeur+$xPtr->; "&xml")+","+String($hauteur+$yPtr->; "&xml")+")")
: ($quoi="LireParamsTranslate")
// mettre dans $3 et $4 les arguments "translate" de $2
// chercher "translate"
$déplacementX:=Position("translate("; $textePtr->)
$texte:=Substring($textePtr->; Length("translate(")+1)
$déplacementX:=Position(","; $texte)
// translation X
$xPtr->:=Num(Substring($texte; 1; $déplacementX-1))
$déplacementY:=Position(")"; $texte)
// translation Y
$yPtr->:=Num(Substring($texte; $déplacementX+1; $déplacementY-$déplacementX-1))
End case
End case
⇧
[class]Personnes - 09/02/2026 10:01:18
property lesEvents : cs.EventsSelect
// utilisés par les appelants
property IDunique : Text
property ID : Integer
property sexe : Boolean
Class extends _ARB_DataStore
Class constructor($IDentité : Variant)
// initialiser l'objet avec les données de l'entité $IDentité de la BDD
Super("Personnes"; $IDentité)
This.lesEvents:=Null
// ----------------------
//MARK:Entité Wrappers
// ----------------------
Function Libellé($formats : Object)->$libellé : Text
$libellé:=This.fct.Libellé($formats)
Function Age($aLaDate : Date)->$result : Object
// Calcul de l'âge de this à :
// . à la date $1
// . à sa mort (si $1 est absent)
// . à aujourd'hui (si $1 est absent et pas mort)
// Sortie
// . $0 = 0 si calcul ok, ou -1 si absence de naissance, -2 si absence de décès, -3 si décédé avant $2.date
// . $data.âge
// . $data.âgeSTR
var $Event : Object
var $dateNaissance; $dateDécès; $dateCalcul : Date
var $age : Integer
$result:=New object("Contexte"; 0)
$Event:=This.Naissance()
If ($Event=Null)
// pas de naissance
$result.Contexte:=3120
Else
// date de naissance
$dateNaissance:=$Event.dateNum
// date de décès
$Event:=This.Décès()
If (Not($Event=Null))
$dateDécès:=$Event.dateNum
End if
Case of
: (Count parameters=1)
// calculer l'âge à la date demandée
$dateCalcul:=$aLaDate
// filtrer les cas impossibles
Case of
: ($dateDécès=!00-00-00!)
: ($dateDécès<$aLaDate)
// décédé avant la date demandée
$result.Contexte:=3121
End case
: ($dateDécès=!00-00-00!)
$dateCalcul:=Current date
End case
// on calcule quelque chose
$age:=Year of($dateCalcul)-Year of($dateNaissance)-1
If ((Month of($dateCalcul)>Month of($dateNaissance)) | (((Month of($dateCalcul)=Month of($dateNaissance)) & (Day of($dateCalcul)>=Day of($dateNaissance)))))
$age:=$age+1
End if
Case of
: ($result.Contexte>0)
// on connait la situation
: ($age<0)
$result.Contexte:=3120
: ($age>110)
$result.Contexte:=3122
Else
$result.Contexte:=3119
End case
$result.âge:=$age
$result.âgeSTR:=String($age)+Localized string("1002")+Choose($age>1; "s"; "")
End if
Function Naissance()->$result : Object
// renvoie un objet _EvenementPersonnel
$result:=This._EvenementPersonnel(22000)
Function Baptême()->$result : Object
// renvoie un objet _EvenementPersonnel
$result:=This._EvenementPersonnel(22300)
Function Décès()->$result : Object
// renvoie un objet _EvenementPersonnel
$result:=This._EvenementPersonnel(22100)
Function _EvenementPersonnel($type : Integer)->$result : Object
// renvoie l'entité events perso de type $1
var $c : Collection
If (This.lesEvents=Null)
This.lesEvents:=This.LesEvents()
End if
$result:=Null
$c:=This.lesEvents.selection.query("type = :1"; $type)
If ($c.length>0)
$result:=$c[0]
End if
Function getEventPersonnel($type : Integer)->$result : Object
// renvoie l'entité events perso de type $1
var $c : Collection
$result:=Null
$c:=This.LesEvents().selection.query("type = :1"; $type)
If ($c.length>0)
$result:=$c[0]
End if
// ----------------------
//MARK:Sélection
// ----------------------
// attention, les liens généalogiques (Parents et conjoint) ne peuvent pas être traités ici en direct
// la création des personnes ramènerait ici, d'où un bouclage infernale
// Parents et conjoints sont accessibles par les fonctions suivantes
Function LesEvents()->$result : cs.EventsSelect
// créer la collection des events
$result:=cs.EventsSelect.new(This.fct.LesEvents())
$result.Créer()
Function LesUnions()->$result : cs.UnionsSelect
// créer la collection des unions triées par date
$result:=cs.UnionsSelect.new(This.fct.LesUnions())
$result.Créer()
// trier les unions par date
$result.selection:=$result.selection.orderBy("leEvent.dateNum asc")
Function UnionParentale()->$result : Collection
$result:=New collection
If (This.fct.LesParents()>0)
$result.push(cs.Unions.new(This.fct.LesParents()))
End if
Function LesParents()->$result : Collection
// créer un objet des parents : membre1 = père, membre2 = mère
var $union : cs.Unions
$result:=New collection
// l'union parentale
$union:=cs.Unions.new(This.fct.LesParents())
// créer les membres de $union : lesMembres .membre1 = homme, .membre2 = femme
// peuvent être Null
$union.LesProtagonistes()
// retour ; ici on ne veut pas de Null
If ($union.lesMembres#Null)
If ($union.lesMembres.membre1#Null)
$result.push($union.lesMembres.membre1)
End if
If ($union.lesMembres.membre2#Null)
$result.push($union.lesMembres.membre2)
End if
End if
⇧
[class]__test - 03/02/2026 19:22:44
Class extends _composant
Class constructor($params : Object)
Super()
If (Count parameters>0)
This.paramsArbre:=$params
End if
// ----------------------
// MARK:Test interne
// ----------------------
Function Démarrer($params : Object)
// simuler un user process
var $data : Object
var $numProc : Integer
// on a appelé le WK : ré-initialiser le contexte, au besoin
This.InitProcess()
$data:=New object
//$data:=cs._menus.new()
$data.functionID:="InitArbrographie"
$data.nomProcess:="U_Nav TestAG"
$data.nomTache:="$ProcessTestAG"
$data.numProcessAppelant:=-1
$data.params:=$params
$numProc:=Exécuter Function Coopérative(cs.__test; $data)
Function InitArbrographie($params : Object)->$result : Object
// méthode du process U_Nav Arbrographie (test local)
var $wndNum : Integer
var $data; $paramsArbre : Object
This.InitProcess()
MouseX:=0 // init des variables du process (nécessaire en interprété)
MouseY:=0
$paramsArbre:=$params.params
// créer la fenêtre
// pour test
$wndNum:=Open window(50; 120; 900; 700; 8; "")
// fixer le retour
$paramsArbre.numFenetreAppelante:=$wndNum
OB REMOVE($paramsArbre; "numProcessAppelant") // au cas où!
$paramsArbre.tache:=cs.xSDK.RegistreTaches.new().Inscrire(New object("nomProcess"; Current process name; "nomTache"; "testAfficherArbre"; "numProcessAppelant"; Current process))
//$data:=cs.$arbre.new($params.params)
$data:=cs.__test.new()
$data.paramsArbre:=$params.params
DIALOG("Test Visualiser Arbre"; $data)
CLOSE WINDOW
// ----------------------
// MARK:Call du SUBFORM
// ----------------------
Function onSurVolElement()
// affichage, pour debug :
// attention : ici on n'est pas dans le sous formulaire : Form n'existe pas, mais 'paramsArbre' est à jour
Form.numTable:=Form.paramsArbre.Navigation.ZS.numTable
Form.UUID_BDD:=Form.paramsArbre.Navigation.ZS.UUID_BDD
Form.OverElementID_SVG:=Form.paramsArbre.EtatProcessus.OverElementID_SVG
Form.SelectedElementID_SVG:=Form.paramsArbre.EtatProcessus.SelectedElementID_SVG
Form.OverInformationID_SVG:=Form.paramsArbre.EtatProcessus.OverInformationID_SVG
Form.SelectedInformationID_SVG:=Form.paramsArbre.EtatProcessus.SelectedInformationID_SVG
Form.PositionX:=-1
Form.PositionY:=-1
If (OB Is defined(Form.paramsArbre.EtatProcessus; "PositionX"))
Form.PositionX:=Form.paramsArbre.EtatProcessus.PositionX
Form.PositionY:=Form.paramsArbre.EtatProcessus.PositionY
End if
Function onModification()
var $paramsArbre : Object
// utiliser les paramètres du sous formulaire
$paramsArbre:=OB Copy(This.paramsArbre)
cs.$arbre.new($paramsArbre).Modifier_AG()
// ----------------------
// MARK:Modification
// ----------------------
Function ModifierTraduction()
// ouvrir l'éditeur des traductions
cs.xSDK.TraductionsEditeur.new().ModifierTraductions()
⇧
[class]Communes - 13/01/2025 12:52:34
Class extends _ARB_DataStore
Class constructor($IDentité : Variant)
// initialiser l'objet avec les données de l'entité $IDentité de la BDD
Super("Communes"; $IDentité)
⇧
[class]localDataStore - 29/05/2025 13:47:24
property DataClassNom; IDunique : Text
property ID; numTable : Integer
Class constructor($DataClassNom : Text; $numTable : Integer)
This.DataClassNom:=$DataClassNom
This.numTable:=$numTable
This.ID:=-1
This.IDunique:=""
Function Créer($data : Object)
// recopier les attributs (de stockage et relationnel) de $data dans this
var $i : Integer
var $objet; $entité : Object
ARRAY TEXT($tabNoms; 0)
ARRAY LONGINT($tabTypes; 0)
OB GET PROPERTY NAMES($data; $tabNoms; $tabTypes)
For ($i; 1; Size of array($tabNoms))
Case of
: ($tabTypes{$i}=Is object)
// plusieurs cas
Case of
: ($tabNoms{$i}="proto@")
// passer
: ($tabNoms{$i}="lesMembres")
// verrue
This["lesMembres"]:=New object
// une entité de la BDD
$objet:=$data["lesMembres"]["membre1"]
Case of
: ($objet=Null)
: (OB Is empty($objet))
Else
$entité:=cs[$objet.DataClassNom].new()
$entité.Créer($objet)
This["lesMembres"]["membre1"]:=$entité
End case
$objet:=$data["lesMembres"]["membre2"]
Case of
: ($objet=Null)
: (OB Is empty($objet))
Else
$entité:=cs[$objet.DataClassNom].new()
$entité.Créer($objet)
This["lesMembres"]["membre2"]:=$entité
End case
: (Not(OB Is defined($data[$tabNoms{$i}]; "DataClassNom")))
// possible?
Else
// une entité de la BDD
$objet:=$data[$tabNoms{$i}]
$entité:=cs[$objet.DataClassNom].new()
$entité.Créer($objet)
This[$tabNoms{$i}]:=$entité
End case
: ($tabTypes{$i}=Is collection)
// deux types de collection : des ID ou des objets
// attribut relationnel, de nom $tabNoms{$i}
This[$tabNoms{$i}]:=New collection
Case of
: ($data[$tabNoms{$i}].length=0)
// c'est fini
: (Value type($data[$tabNoms{$i}][0])=Is real)
// une collection d'ID : recopier la collection
This[$tabNoms{$i}]:=$data[$tabNoms{$i}]
Else
// une collection d'objets (associés à une classe)
// créer une instance de classe pour chaque élément de la collection
For each ($objet; $data[$tabNoms{$i}])
$entité:=cs[$objet.DataClassNom].new()
$entité.Créer($objet)
This[$tabNoms{$i}].push($entité)
End for each
End case
Else
// attribut de stokage
OB SET(This; $tabNoms{$i}; OB Get($data; $tabNoms{$i}; $tabTypes{$i}))
End case
End for
Function IDcodé()->$IDcodé : Integer
$IDcodé:=CodeEnreg(This.ID; [This.numTable])
Function Libellé($formats : Object)->$libellé : Text
// fonction bouchon
$libellé:="entité "+String(This.ID)+" de "+This.DataClassNom
// ----------------------
// MARK:Sélections
// -----------------------
Function Le($DataClassNomCible : Text)->$result : Object
// renvoie l'entité $DataClassNomCible
var $DataClassNom; $attribut : Text
$DataClassNom:=This.DataClassNom
Case of
: ($DataClassNom=$DataClassNomCible)
// on y est :
$result:=This
: ($DataClassNom="Lieux")
$attribut:="leSite"
: ($DataClassNom="Sites")
$attribut:="laCommune"
: ($DataClassNom="Communes")
$attribut:="leDepartement"
: ($DataClassNom="Departements")
$attribut:="laRegion"
: ($DataClassNom="Regions")
$attribut:="lePays"
: ($DataClassNom="Pays")
$attribut:=""
End case
If ($attribut#"")
$result:=This[$attribut].Le($DataClassNomCible)
End if
Function getRelatedEntity($chemin : Text)->$entité : Object
var $c : Collection
var $dataTexte; $lien : Text
// remonter le chemin $chemin de this
$dataTexte:=$chemin
If ($dataTexte="@_@")
$c:=Split string($dataTexte; "_")
// nom de l'attribut de l'end entité
$dataTexte:=$c.pop()
$entité:=This
For each ($lien; $c)
$entité:=$entité[$lien]
End for each
Else
$entité:=This
End if
// ----------------------
//MARK:Saisie
// -----------------------
Function addAttribut($nom : Text; $valeur : Text; $type : Integer)->$result : Boolean
var $valeurEL : Integer
$result:=True
Case of
: ($type=Is text)
This[$nom]:=$valeur
: ($type=Is boolean)
// les booléens des FORM sont codés 0 / 1, ici convertis en chaine
This[$nom]:=($valeur="1")
: ($type=Is longint)
$valeurEL:=Num($valeur) // typé entier long
This[$nom]:=$valeurEL
Else
// type non traité
$result:=False
End case
Function estEntitéVide()->$result : Boolean
// this est vide si aucune de ses données a été saisie
// this est vide si data ne contient que DataClassNom et ID (et type pour les events)
var $entité : Object
var $i : Integer
$entité:=OB Copy(This)
// supprimer l'entête (cf constructeur)
OB REMOVE($entité; "DataClassNom")
OB REMOVE($entité; "ID")
OB REMOVE($entité; "IDunique")
OB REMOVE($entité; "numTable")
// supprimer les données non saisissables
OB REMOVE($entité; "aQuiDataClassNom")
OB REMOVE($entité; "aQuiIDunique")
OB REMOVE($entité; "type")
OB REMOVE($entité; "dateNum")
OB REMOVE($entité; "heure")
// supprimer les valeurs saisissables nulles
ARRAY TEXT($tabNoms; 0)
OB GET PROPERTY NAMES($entité; $tabNoms)
For ($i; 1; Size of array($tabNoms))
Case of
: (OB Get type($entité; $tabNoms{$i})#Is text)
: ($entité[$tabNoms{$i}]#"")
Else
OB REMOVE($entité; $tabNoms{$i})
End case
Case of
: (OB Get type($entité; $tabNoms{$i})#Is real)
: ($entité[$tabNoms{$i}]#0)
Else
// pas saisi
OB REMOVE($entité; $tabNoms{$i})
End case
// remarque : le type booléen est saisissable mais ne peut être nul !
// supprimer les liens de structure
Case of
: (OB Get type($entité; $tabNoms{$i})=Is collection)
OB REMOVE($entité; $tabNoms{$i})
: (OB Get type($entité; $tabNoms{$i})=Is object)
OB REMOVE($entité; $tabNoms{$i})
End case
End for
$result:=OB Is empty($entité)
// ----------------------
// MARK:Utilitaires
// -----------------------
Function initResult($Error : Integer; $ErrorDescription : Text; $success : Boolean)->$result : Object
If (Count parameters=0)
$Error:=0
$ErrorDescription:=""
$success:=True
End if
$result:=New object("Error"; $Error; "ErrorDescription"; $ErrorDescription; "success"; $success)
$result.entité:=Null
⇧
[class]EventsSelect - 13/01/2025 12:36:47
Class extends _ARB_DataStore
Class constructor($requête : Variant)
Super("EventsSelect"; $requête)
This.selection:=Null
Function LesProtagonistes()->$result : cs.PersonnesSelect
$result:=cs.PersonnesSelect.new(This.fct.LesProtagonistes())
⇧
[class]_deploiement - 15/04/2026 10:26:47
Class extends $arbre
Class constructor($params : Object)
Super($params)
// ----------------------
// MARK:Déploiement
// ----------------------
Function Deployer_AG($tablesBDD_AG : Object)
var $IDarbre; $i; $itemRef; $x; $y : Integer
var $result : Boolean
This.InitProcess()
This.trace.Initialiser(Current method name)
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; "Déploiement"; Current method name; "Initialisation"; New object("nomProcess"; Current process name; "numProcess"; Current process))
$IDarbre:=This.paramsArbre.IDarbre
// lire les données de l'arbre
// initialiser les tableaux de données (initialise aussi BDD_AG)
ARRAY LONGINT(champINT; 23; 0)
ARRAY REAL(champREAL; 23; 0)
ARRAY BOOLEAN(champBOOL; 23; 0)
This.EcrireTableauxBDD_AG($tablesBDD_AG)
// calculer la position des cadres; le déploiement se fait calque par calque
// chercher tous les calques (en fait leur connexion origine)
ARRAY LONGINT($tabCalques; 0)
ARRAY LONGINT($tabConnexions; 0)
ARRAY LONGINT($tabOrdres; 0)
//%W-518.1
COPY ARRAY(BDD_AG{calques_ID}->; $tabCalques)
COPY ARRAY(BDD_AG{calques_origine}->; $tabConnexions)
COPY ARRAY(BDD_AG{calques_num_ordre}->; $tabOrdres)
//%W+518.1
// trier les calques
SORT ARRAY($tabOrdres; $tabCalques; $tabConnexions; >)
This.trace.Error:=-16317*Num(Size of array($tabCalques)=0)
This.trace.ErrorDescription:="Déploiement de l'arbre : absence de calques"
This.trace.LeverException(This.paramsArbre.optionsMsg)
// lancer le déploiement de chaque calque à partir de sa connexion origine
For ($i; 1; Size of array($tabCalques))
This.trace:=This.DeployerCadre($tabConnexions{$i}; $tabCalques{$i})
If (This.trace.Error#0)
$i:=Size of array($tabCalques)+1 // purger
End if
End for
// lancer le traitement des liens consanguins
If (This.trace.Error=0)
ASSERT(cs._Trace.new().DebugerMethode("Déploiement"; Current method name; "Traitement des liens consanguins"))
ProcInProgressTime:=0
// les déployer
// * d'abord il faut leur connexion origine
ARRAY LONGINT($tabConnexions; 0)
ARRAY LONGINT($tabID; 0)
$itemRef:=320
$i:=1
This.SelectionnerDansBDD_AG(BDD_AG{cadres_type_element}; "="; ->$itemRef; "*"; [BDD_AG{cadres_ID}; ->$tabID])
This.SelectionnerDansBDD_AG(BDD_AG{connexions_cadre_lie}; "IN"; ->$tabID; "*")
This.SelectionnerDansBDD_AG(BDD_AG{connexions_num_logic_lie}; "="; ->$i; "ET"; [BDD_AG{connexions_ID}; ->$tabConnexions])
For ($i; 1; Size of array($tabConnexions))
// * lancer le déploiement du cadre $i à partir de sa connexion origine
This.DeployerCadre($tabConnexions{$i}; -1)
End for
This.trace.LeverException(This.paramsArbre.optionsMsg)
End if
// déploiements ascendant et descendant terminés : ratabouter les branches avec le cadre De-Cujus
ASSERT(cs._Trace.new().DebugerMethode("Déploiement"; Current method name; "Connexion des branches Xcendantes"))
// chercher les connexions du De-Cujus
$itemRef:=0
This.LireEnregistrementBDD_AG(BDD_AG{cadres_type_element}; "="; ->$itemRef; "-"; [BDD_AG{cadres_ID}; ->$i])
This.SelectionnerDansBDD_AG(BDD_AG{connexions_cadre}; "="; ->$i; "*"; [BDD_AG{connexions_ID}; ->$tabConnexions])
// déploiement terminé : recadrer le dessin dans le coin haut / gauche
// décaler les branches
For ($i; 1; Size of array($tabConnexions))
This.DeployerBranche($tabConnexions{$i})
End for
// calculer le décalage
ARRAY REAL($tabGauche; 0)
ARRAY REAL($tabHaut; 0)
$result:=True
This.SelectionnerDansBDD_AG(BDD_AG{cadres_deployed}; "="; ->$result; "*"; [BDD_AG{cadres_gauche}; ->$tabGauche; BDD_AG{cadres_haut}; ->$tabHaut])
$x:=Min($tabGauche)
$y:=Min($tabHaut)
// déplacer les cadres (marge de 5 px à gauche et en haut)
For ($i; 1; Size of array(BDD_AG{cadres_deployed}->))
BDD_AG{cadres_gauche}->{$i}:=BDD_AG{cadres_gauche}->{$i}-$x+5
BDD_AG{cadres_haut}->{$i}:=BDD_AG{cadres_haut}->{$i}-$y+5
End for
// c'est fini
// voir le déploiement
ASSERT(This.trace.DEBUG_STORE_PICT_BDD_AG(String(Milliseconds)+"-Arbre_"+String(This.paramsArbre.IDarbre)+"_déployé"; This.paramsArbre))
// fixer les données traitées
This.paramsArbre.tablesBDD_AG:=This.LireTableauxBDD_AG()
// faire faire la mise à jour de la BDD_AG par le Worker appelant (toujours un WK, car ici on est a priori préemptif)
This.paramsArbre.functionID:=cagk Appliquer Déploiement
// renvoyer la commande
This.trace.Error:=-16303*Num(Not(OB Is defined(This.paramsArbre.EtatProcessus; "WorkerAppelant")))
This.trace.ErrorDescription:="le nom du Worker appelant est inconnu"
CALL WORKER(OB Get(This.paramsArbre.EtatProcessus; "WorkerAppelant"; Is text); Formula from string("cs._modification_BDD_AG.new($1).Exécuter()"); This.paramsArbre)
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; "Déploiement"; Current method name; "Terminé"; New object("nomProcess"; Current process name; "numProcess"; Current process))
This.trace.LeverException(This.paramsArbre.optionsMsg)
Function DeployerCadre($IDconnexionOrigine : Integer; $IDcalqueOrigine : Integer)->$result : cs._Trace
// calcul de la position du cadre connecté à $IDconnexionOrigine (du calque $IDcalqueOrigine)
var $IDcadreCourant; $IDcadreGenant; $IDcalque; $IDcadre; $IDconnexion; $ID; $numLogic; $i; $direction; $typeElement : Integer
var $gauche; $haut; $largeur; $hauteur; $x_delta; $y_delta; $x; $y : Real
var $deployed; $initDeployment; $garder : Boolean
var $IDboucle; $traceIDboucle : Text
var $décompteRepeter : Integer
$result:=cs._Trace.new().Initialiser(Current method name)
$gauche:=0 // pour que le compilateur 4D n'oublie pas que ces variables existent
$haut:=0
// vérifier que le cadre lié à $IDconnexionOrigine n'est pas déployé, est initialisé et appartient au calque $IDcalqueOrigine
$IDconnexion:=$IDconnexionOrigine
// erreurs non gérées
// récupérer l'ID du cadre de $IDconnexion
This.LireEnregistrementBDD_AG(BDD_AG{connexions_ID}; "="; ->$IDconnexion; "-"; [BDD_AG{connexions_cadre_lie}; ->$IDcadreCourant])
// récupérer l'état de déploiement et le type du cadre de $IDconnexionOrigine
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$IDcadreCourant; "-"; [BDD_AG{cadres_deployed}; ->$deployed; BDD_AG{cadres_init_deploiement}; ->$initDeployment; BDD_AG{cadres_calque}; ->$IDcalque; BDD_AG{cadres_type_element}; ->$typeElement])
Case of
: (Not($deployed) & $initDeployment & ($IDcalque=$IDcalqueOrigine) & Not($typeElement=320))
// cas général
// ici le cadre doit être non déployé, du calque courant et ne pas être un lien consanguin (superposable à tous, donc non géré ici)
ASSERT(cs._Trace.new().DebugerMethode("Déploiement"; Current method name; "Initialisation de la position du cadre courant "+String($IDcadreCourant)))
// Calculer la position du cadre du connecteur $IDconnexionOrigine (cadre courant)
$IDcadreCourant:=This.CalculerPositionCadre($IDconnexionOrigine)
// pré-calcul (au cas où ça bignerait) : chercher la lignée ascendante de $IDcadreCourant jusqu'au DeCujus
// la lignée ascendante est définie par les 3 tableaux : $tabCadres, $tabTypesElement, $tabConnexions
$IDconnexion:=$IDconnexionOrigine
ARRAY LONGINT($tabCadres; 0) // liste des cadres ascendant jusqu'au De-Cujus
ARRAY LONGINT($tabTypesElement; 0) // liste des types élément de ces cadres
ARRAY LONGINT($tabConnexions; 0) // liste des connexions de ces cadres
$décompteRepeter:=50 // générations max
Repeat
$décompteRepeter:=$décompteRepeter-1
// sélectionner le cadre amont de la connexion
$ID:=$IDconnexion // mémoriser
This.LireEnregistrementBDD_AG(BDD_AG{connexions_ID}; "="; ->$IDconnexion; "-"; [BDD_AG{connexions_cadre}; ->$IDcadre])
// récupérer le type du cadre
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$IDcadre; "-"; [BDD_AG{cadres_type_element}; ->$typeElement])
// passer à la connexion suivante
$numLogic:=1
This.LireEnregistrementBDD_AG(BDD_AG{connexions_cadre_lie}; "="; ->$IDcadre; "*")
This.LireEnregistrementBDD_AG(BDD_AG{connexions_num_logic_lie}; "="; ->$numLogic; "ET")
$IDconnexion:=0
If (Size of array(indices)>0)
$IDconnexion:=BDD_AG{connexions_ID}->{indices{1}}
End if
APPEND TO ARRAY($tabCadres; $IDcadre)
APPEND TO ARRAY($tabConnexions; $ID)
APPEND TO ARRAY($tabTypesElement; $typeElement)
Until (($IDcadre=0) | ($décompteRepeter<0))
cs._Trace.me.Créer(-16321*Num($décompteRepeter<0); Current method name; "impossible de remontée la lignée depuis le connecteur "+String($IDconnexionOrigine)).LeverException([msgk_event; msgk_log])
// rechercher et traiter les bignes
$traceIDboucle:="" // traceur pour détecter un bouclage du repeter
Repeat
// ça bigne ?
ARRAY LONGINT($tableau; 0)
$IDcalque:=0
$largeur:=0
$hauteur:=0
// récupérer les données du cadre courant
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$IDcadreCourant; "-"; [BDD_AG{cadres_calque}; ->$IDcalque; BDD_AG{cadres_gauche}; ->$gauche; BDD_AG{cadres_haut}; ->$haut; BDD_AG{cadres_largeur}; ->$largeur; BDD_AG{cadres_hauteur}; ->$hauteur])
// chercher les cadres du calque courant intersectant le cadre courant : dans l'ordre (plus facile en SQL !)
// *** lister tous les autres cadres
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "#"; ->$IDcadreCourant; "*")
// *** garder les cadres déployés du calque courant
$deployed:=True
This.LireEnregistrementBDD_AG(BDD_AG{cadres_deployed}; "="; ->$deployed; "ET")
This.LireEnregistrementBDD_AG(BDD_AG{cadres_calque}; "="; ->$IDcalque; "ET")
// la sélection est dans le tableau "indices"
COPY ARRAY(indices; $tableau)
// *** supprimer ceux qui ne bignent pas
For ($i; Size of array($tableau); 1; -1)
$garder:=(BDD_AG{cadres_gauche}->{$tableau{$i}}<($gauche+$largeur))
$garder:=$garder & (BDD_AG{cadres_haut}->{$tableau{$i}}<($haut+$hauteur))
$garder:=$garder & ((BDD_AG{cadres_gauche}->{$tableau{$i}}+BDD_AG{cadres_largeur}->{$tableau{$i}})>$gauche)
$garder:=$garder & ((BDD_AG{cadres_haut}->{$tableau{$i}}+BDD_AG{cadres_hauteur}->{$tableau{$i}})>$haut)
If (Not($garder))
DELETE FROM ARRAY($tableau; $i)
End if
End for
// *** calculer les paramètres de bigne sur ce qui reste
ARRAY REAL($tabDeltaX; Size of array($tableau))
ARRAY REAL($tabDeltaY; Size of array($tableau))
ARRAY REAL($tabDistance; Size of array($tableau))
For ($i; 1; Size of array($tableau))
$tabDeltaX{$i}:=BDD_AG{cadres_gauche}->{$tableau{$i}}+BDD_AG{cadres_largeur}->{$tableau{$i}}-$gauche
$tabDeltaY{$i}:=BDD_AG{cadres_haut}->{$tableau{$i}}+BDD_AG{cadres_hauteur}->{$tableau{$i}}-$haut
$tabDistance{$i}:=((BDD_AG{cadres_gauche}->{$tableau{$i}}+BDD_AG{cadres_largeur}->{$tableau{$i}})^2)+((BDD_AG{cadres_haut}->{$tableau{$i}}+BDD_AG{cadres_hauteur}->{$tableau{$i}})^2)
$tabDistance{$i}:=Square root($tabDistance{$i})
End for
If (Size of array($tableau)>0) // oui ça bigne : dé-superposer
// trier les cadres du plus éloigné au plus près
SORT ARRAY($tabDistance; $tableau; $tabDeltaX; $tabDeltaY; <)
$IDcadreGenant:=BDD_AG{cadres_ID}->{$tableau{1}}
$IDboucle:=String($IDcadreCourant)+"-"+String($IDcadreGenant)
If ($IDboucle#$traceIDboucle)
ASSERT(cs._Trace.new().DebugerMethode("Dé-superposition"; Current method name; "Le cadre "+String($IDcadreCourant)+" bigne avec le cadre "+String($IDcadreGenant)))
$traceIDboucle:=$IDboucle
// traiter le premier cadre de la liste : $IDcadreGenant
//-- calcul du décalage requis pour placer le cadre courant au delà du cadre $IDcadreGenant
//-- chercher la connexion de $IDcadreGenant
$numLogic:=1
This.LireEnregistrementBDD_AG(BDD_AG{connexions_cadre_lie}; "="; ->$IDcadreGenant; "*")
This.LireEnregistrementBDD_AG(BDD_AG{connexions_num_logic_lie}; "="; ->$numLogic; "ET")
$IDconnexion:=0
If (Size of array(indices)>0)
$IDconnexion:=BDD_AG{connexions_ID}->{indices{1}}
End if
$x_delta:=$tabDeltaX{1}+10
$y_delta:=$tabDeltaY{1}+10
// chercher le cadre commun à $IDcadreCourant et $IDcadreGenant, boucle pour remonter la lignée ascendante de $IDcadreGenant
$décompteRepeter:=50 // générations max
Repeat
$décompteRepeter:=$décompteRepeter-1
$IDcadre:=-1
This.LireEnregistrementBDD_AG(BDD_AG{connexions_ID}; "="; ->$IDconnexion; "-"; [BDD_AG{connexions_cadre}; ->$IDcadre])
$numLogic:=1
This.LireEnregistrementBDD_AG(BDD_AG{connexions_cadre_lie}; "="; ->$IDcadre; "*")
This.LireEnregistrementBDD_AG(BDD_AG{connexions_num_logic_lie}; "="; ->$numLogic; "ET")
$IDconnexion:=0
$direction:=-1
If (Size of array(indices)>0)
$IDconnexion:=BDD_AG{connexions_ID}->{indices{1}}
$direction:=BDD_AG{connexions_direction}->{indices{1}}
End if
If ($IDcadre>0)
// pas encore la fin de la lignée
If (Find in array($tabCadres; $IDcadre)>0) // cadre commun trouvé
// dé superposer le cadre
// plusieurs cas de dé-superposition, suivant le type d'élément commun
$typeElement:=$tabTypesElement{Find in array($tabCadres; $IDcadre)}
Case of
: (($typeElement=224) | ($typeElement=256)) // la croisée des chemin conduit à un lien de Xcendance
// * calculer le sens de déplacement (direction = Azimut radar!)
// principe : le déplacement se fait toujours vers la droite ($delta_X) ou vers le bas ($delta_Y)
Case of
: (($direction=0) | ($direction=180))
$x_delta:=0
: (($direction=90) | ($direction=270))
$y_delta:=0
Else
cs._Trace.me.Créer(-16310; Current method name; "La direction ("+String($direction)+") du connecteur "+String($IDconnexion)+" du cadre "+String($IDcadre)+" type "+String($typeElement)+" est incorrecte").LeverException([msgk_event; msgk_log])
End case
// * modifier la position réduite des connecteurs et la taille du cadre commun
$IDconnexion:=$tabConnexions{Find in array($tabCadres; $IDcadre)}
$numLogic:=0
// lire le num logic du connecteur à déplacer
This.LireEnregistrementBDD_AG(BDD_AG{connexions_ID}; "="; ->$IDconnexion; "-"; [BDD_AG{connexions_num_logic}; ->$numLogic])
// lire les dimensions du cadre qui possède le connecteur à déplacer
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$IDcadre; "-"; [BDD_AG{cadres_largeur}; ->$largeur; BDD_AG{cadres_hauteur}; ->$hauteur])
ASSERT(cs._Trace.new().DebugerMethode("Dé-superposition"; Current method name; "Déplacement du connecteur "+String($IDconnexion)+" du cadre "+String($IDcadre)+" type "+String($typeElement)+" x = "+String($x_delta; "######0.00")+", y = "+String($y_delta; "######0.00")))
// ** maintenir la position des connecteurs précédents
// *** sélectionner les connecteurs précédents, et lire la position réduite courante
ARRAY REAL($tabX_réduit; 0)
ARRAY REAL($tabY_réduit; 0)
This.LireEnregistrementBDD_AG(BDD_AG{connexions_cadre}; "="; ->$IDcadre; "*")
This.SelectionnerDansBDD_AG(BDD_AG{connexions_num_logic}; "<"; ->$numLogic; "ET"; [BDD_AG{connexions_x_reduit}; ->$tabX_réduit; BDD_AG{connexions_y_reduit}; ->$tabY_réduit])
For ($i; 1; Size of array($tabX_réduit))
// *** calculer la nouvelle position réduite
$tabX_réduit{$i}:=(($tabX_réduit{$i}+0.5)*$largeur/($x_delta+$largeur))-0.5
$tabY_réduit{$i}:=(($tabY_réduit{$i}+0.5)*$hauteur/($y_delta+$hauteur))-0.5
End for
// *** mettre à jour
This.EcrireSelectionBDD_AG(->indices; [BDD_AG{connexions_x_reduit}; ->$tabX_réduit; BDD_AG{connexions_y_reduit}; ->$tabY_réduit])
// ** déplacer le connecteur (et les suivants, pas forcément liés)
// *** sélectionner les connecteurs précédents, et lire la position réduite courante
ARRAY REAL($tabX_réduit; 0)
ARRAY REAL($tabY_réduit; 0)
This.LireEnregistrementBDD_AG(BDD_AG{connexions_cadre}; "="; ->$IDcadre; "*")
This.SelectionnerDansBDD_AG(BDD_AG{connexions_num_logic}; ">="; ->$numLogic; "ET"; [BDD_AG{connexions_x_reduit}; ->$tabX_réduit; BDD_AG{connexions_y_reduit}; ->$tabY_réduit])
For ($i; 1; Size of array($tabX_réduit))
// *** calculer la nouvelle position réduite
$tabX_réduit{$i}:=(($x_delta+(($tabX_réduit{$i}+0.5)*$largeur))/($x_delta+$largeur))-0.5
$tabY_réduit{$i}:=(($y_delta+(($tabY_réduit{$i}+0.5)*$hauteur))/($y_delta+$hauteur))-0.5
End for
// *** mettre à jour
This.EcrireSelectionBDD_AG(->indices; [BDD_AG{connexions_x_reduit}; ->$tabX_réduit; BDD_AG{connexions_y_reduit}; ->$tabY_réduit])
// ** mettre à jour les dimensions du cadre (on pourrait le faire avant !)
$x:=$x_delta+$largeur
$y:=$y_delta+$hauteur
This.EcrireEnregistrementBDD_AG(BDD_AG{cadres_ID}; ->$IDcadre; [BDD_AG{cadres_largeur}; ->$x; BDD_AG{cadres_hauteur}; ->$y])
// ** chercher le connecteur de liaison du cadre commun
This.LireEnregistrementBDD_AG(BDD_AG{connexions_cadre_lie}; "="; ->$IDcadre; "*")
$numLogic:=1
This.LireEnregistrementBDD_AG(BDD_AG{connexions_num_logic_lie}; "="; ->$numLogic; "ET")
ASSERT(Size of array(indices)=1; "Déployer cadre xcendance "+String($IDcadre)+" : connecteur d'accrochage non trouvé")
$IDconnexion:=0
If (Size of array(indices)>0)
$IDconnexion:=BDD_AG{connexions_ID}->{indices{1}}
End if
// * décaler de $x_delta/2 et $y_delta/2 la branche ayant pour origine celle du cadre $IDcadre (rappel : commun à $IDcadreCourant et $IDcadreGenant)
This.CalculerPositionBranche(->$IDconnexion; $x_delta/2; $y_delta/2)
// * calculer la position de tous les cadres de cette branche
This.DeployerBranche($IDconnexion)
: (($typeElement=160) | ($typeElement=176)) // la croisée des chemins conduit à une union familiale (autre)
// le cadre à modifier est la dernière union avec un autre conjoint
// chercher dans le chemin le dernier cadre type 176. Commencer à partir du cadre commun
$i:=Find in array($tabCadres; $IDcadre)
$ID:=0
While (($ID=0) & ($i>0))
// remonter de 2 cadres pour l'union suivante
If ($i-2>0)
If ($tabTypesElement{$i-2}=176)
// peut-être le bon cadre, on continue
$i:=$i-2
Else
// trouvé
$ID:=$tabCadres{$i}
End if
Else
$ID:=$tabCadres{$i}
End if
End while
If ($ID>0)
// trouver la direction de déplacement
This.LireEnregistrementBDD_AG(BDD_AG{connexions_cadre_lie}; "="; ->$ID; "*")
$numLogic:=1
This.LireEnregistrementBDD_AG(BDD_AG{connexions_num_logic_lie}; "="; ->$numLogic; "ET")
$direction:=-1
If (Size of array(indices)>0)
$direction:=BDD_AG{connexions_direction}->{indices{1}}
End if
// élargir ce cadre
Case of
: (($direction=0) | ($direction=180))
$y_delta:=0
: (($direction=90) | ($direction=270))
$x_delta:=0
Else
$result.Error:=-16310
$result.ErrorDescription:="La direction ("+String($direction)+") d'un connecteur lié du cadre "+String($ID)+" type "+String($typeElement)+" est incorrecte "
$result.LeverException(This.paramsArbre.optionsMsg)
End case
End if
ASSERT(cs._Trace.new().DebugerMethode("Dé-superposition"; Current method name; "Déplacement de la branche "+String($IDconnexion)+" du cadre "+String($ID)+" type "+String($typeElement)))
// * décaler de $x_delta et $y_delta la branche connectée à $tabConnexions{$i}
$IDconnexion:=$tabConnexions{$i}
This.CalculerPositionBranche(->$IDconnexion; $x_delta; $y_delta)
// * calculer la position de tous les cadres de la branche ayant pour origine celle du cadre $IDcadre (rappel : commun à $IDcadreCourant et $IDcadreGenant)
// chercher le connecteur de liaison du cadre commun
This.DeployerBranche($IDconnexion)
Else
// pas normal
$result.Error:=-16319
$result.ErrorDescription:="le type "+String($typeElement)+" du cadre "+String($IDcadre)+" ne peut être utilisé pour la dé-superposition"
$result.LeverException(This.paramsArbre.optionsMsg)
End case
// c'est fini avec ce cadre
// renseigner la progression
ARRAY LONGINT($indices; 0)
$garder:=True
This.ChercherDansTableauxBDD_AG(BDD_AG{cadres_deployed}; "="; ->$garder; ->$indices)
ProcInProgressTime:=10000*Size of array($indices)/Size of array(BDD_AG{cadres_deployed}->)
$IDcadre:=-1
End if
End if
Until (($IDcadre=-1) | ($décompteRepeter<0))
$result.Error:=-16321*Num($décompteRepeter<0)
$result.ErrorDescription:="impossible de remontée la lignée depuis le cadre "+String($IDcadreGenant)
$result.LeverException(This.paramsArbre.optionsMsg)
Else
// arrêter le massacre !
$result.Error:=-16320
$result.ErrorDescription:="dé-superposition impossible du cadre "+String($IDcadreCourant)+" et du cadre "+String($IDcadreGenant)+" (timeOut du bouclage du repeter)"
$result.LeverException(This.paramsArbre.optionsMsg)
End if
End if
Until ((Size of array($tableau)=0) | ($result.Error#0))
If ($result.Error=0)
// déployer les cadres liés au cadre courant $IDcadreCourant et du calque courant $IDcalque
// chercher tous les connecteurs de liaisons
ARRAY LONGINT($tableau; 0)
ARRAY LONGINT($tabOrdres; 0)
This.SelectionnerDansBDD_AG(BDD_AG{connexions_cadre}; "="; ->$IDcadreCourant; "*"; [BDD_AG{connexions_ID}; ->$tableau; BDD_AG{connexions_num_logic}; ->$tabOrdres])
SORT ARRAY($tabOrdres; $tableau; >)
// on continue avec les cadres suivants
If (Size of array($tableau)>0) // il y a des cadres connectés
For ($i; 1; Size of array($tableau))
$result:=This.DeployerCadre($tableau{$i}; $IDcalqueOrigine)
If ($result.Error#0)
$i:=Size of array($tableau)+1 // purger
End if
End for
End if
// on est arrivé à une feuille de l'arbre : le cadre est déployé
$deployed:=($result.Error=0)
This.EcrireEnregistrementBDD_AG(BDD_AG{cadres_ID}; ->$IDcadreCourant; [BDD_AG{cadres_deployed}; ->$deployed])
ASSERT(cs._Trace.new().DebugerMethode("Dé-superposition"; Current method name; "Le cadre "+String($IDcadreCourant)+" est déployé"))
ASSERT(This.trace.DEBUG_STORE_PICT_BDD_AG(String(Milliseconds)+"-Cadre_"+String($IDcadreCourant)+"_déployé"; This.paramsArbre))
End if
: (Not($deployed) & $initDeployment & ($IDcalque=$IDcalqueOrigine) & ($typeElement=320))
// ne rien faire, voir le cas suivant (ce cas évite un message d'erreur inutile)
: (($typeElement=320) & ($IDcalqueOrigine=-1))
// cadre lien d'union consanguine
// pas de réel déploiement : calculer les dimensions du cadre suite au déploiement de l'arbre
// récupérer les coordonnées réduites des connecteurs des 2 cadres de l'union consanguine en lien avec $IDcadreCourant
ARRAY LONGINT($tabConnexions; 0)
ARRAY LONGINT($tabCadresEnLien; 0)
ARRAY REAL($tabXreduit; 0)
ARRAY REAL($tabYreduit; 0)
This.SelectionnerDansBDD_AG(BDD_AG{connexions_cadre_lie}; "="; ->$IDcadreCourant; "*"; [BDD_AG{connexions_ID}; ->$tabConnexions; BDD_AG{connexions_cadre}; ->$tabCadresEnLien; BDD_AG{connexions_x_reduit_lie}; ->$tabXreduit; BDD_AG{connexions_y_reduit_lie}; ->$tabYreduit])
// récupérer la position des 2 cadres de l'union consanguine en lien avec $IDcadreCourant
ARRAY REAL($tabGauche; Size of array($tabCadresEnLien))
ARRAY REAL($tabHaut; Size of array($tabCadresEnLien))
ARRAY REAL($tabLargeur; Size of array($tabCadresEnLien))
ARRAY REAL($tabHauteur; Size of array($tabCadresEnLien))
For ($i; 1; Size of array($tabCadresEnLien))
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$tabCadresEnLien{$i}; "-"; [BDD_AG{cadres_gauche}; ->$tabGauche{$i}; BDD_AG{cadres_haut}; ->$tabHaut{$i}; BDD_AG{cadres_largeur}; ->$tabLargeur{$i}; BDD_AG{cadres_hauteur}; ->$tabHauteur{$i}])
End for
// calculer la position des connecteurs $tabConnexions = position des 2 coins de $IDcadreCourant
ARRAY REAL($tabX; 2) // abscisse des 2 coins
ARRAY REAL($tabY; 2) // ordonnées des 2 coins
For ($i; 1; Size of array($tabConnexions))
$tabX{$i}:=$tabGauche{$i}+((0.5+$tabXreduit{$i})*$tabLargeur{$i})
$tabY{$i}:=$tabHaut{$i}+((0.5+$tabYreduit{$i})*$tabHauteur{$i})
End for
// calculer la position du cadre $IDcadreCourant
// d'abord la position du centre du cadre
$x_delta:=($tabX{1}+$tabX{2})/2
$y_delta:=($tabY{1}+$tabY{2})/2
// les dimensions du cadre
$largeur:=Abs($tabX{1}-$tabX{2})
$hauteur:=Abs($tabY{1}-$tabY{2})
// enfin la position du cadre
$gauche:=Min($tabX)
$haut:=Min($tabY)
$deployed:=True
// positionner le cadre
This.EcrireEnregistrementBDD_AG(BDD_AG{cadres_ID}; ->$IDcadreCourant; [BDD_AG{cadres_gauche}; ->$gauche; BDD_AG{cadres_haut}; ->$haut; BDD_AG{cadres_largeur}; ->$largeur; BDD_AG{cadres_hauteur}; ->$hauteur; BDD_AG{cadres_deployed}; ->$deployed])
// calculer les coordonnées réduites des connecteurs liés à $IDcadreCourant
// remarque : dans le dessin, les cadres 320 sont traités comme les autres ==> ces coordonnées réduites sont nécessaires
For ($i; 1; Size of array($tabConnexions))
// calculer les coordonnées centrées réduites du point. Une dimension peut être nulle (hauteur en particulier si les 2 cadres de l'union consanguine sont de la même génération)
$x_delta:=0
If ($largeur>0)
$x_delta:=($tabX{$i}-$gauche)/$largeur // abscisse réduite
End if
$x_delta:=$x_delta-0.5 // abscisse centrée réduite
$y_delta:=0
If ($hauteur>0)
$y_delta:=($tabY{$i}-$haut)/$hauteur // ordonnée réduite
End if
$y_delta:=$y_delta-0.5 // ordonnée centrée réduite
// les affecter à un connecteur
This.EcrireEnregistrementBDD_AG(BDD_AG{connexions_ID}; ->$tabConnexions{$i}; [BDD_AG{connexions_x_reduit_lie}; ->$x_delta; BDD_AG{connexions_y_reduit_lie}; ->$y_delta])
End for
: ($ID=0)
// peut arriver (normal?), filtrer
ASSERT(cs._Trace.new().DebugerMethode("Déploiement"; Current method name; "ID cadre courant = 0, non traité"))
Else
$result.Error:=-16320
$result.ErrorDescription:="déploiement du connecteur "+String($ID)+" du cadre "+String($IDcadreCourant)+" : cas de dé-superposition inconnu"
$result.LeverException(This.paramsArbre.optionsMsg)
End case
Function DeployerBranche($IDconnexion : Integer)
// $1 = ID connexion au cadre origine de la branche
// calculer la position de tous les cadres de la branche d'origine $1
var $IDcadre; $i : Integer
// positionner le cadre courant
$IDcadre:=This.CalculerPositionCadre($IDconnexion)
// chercher les cadres liés au cadre courant
ARRAY LONGINT($tableau; 0)
ARRAY LONGINT($tabOrdres; 0)
This.SelectionnerDansBDD_AG(BDD_AG{connexions_cadre}; "="; ->$IDcadre; "*"; [BDD_AG{connexions_ID}; ->$tableau; BDD_AG{connexions_num_logic}; ->$tabOrdres])
SORT ARRAY($tabOrdres; $tableau; >)
// $IDcadre peut valoir -1 : le traitement s'arrête
// positionner les cadres liés au cadre courant
If (Size of array($tableau)>0) // il y a des cadres connectés
For ($i; 1; Size of array($tableau))
This.DeployerBranche($tableau{$i})
End for
End if
// ----------------------
// MARK:Positionnement
// ----------------------
Function CalculerPositionBranche($ptrIDconnexion : Pointer; $x_delta : Real; $y_delta : Real)
var $IDcadre; $IDcalque; $IDconnecteur; $IDconnexion; $OrigineCalque; $typeElement; $numLogic; $dataValue; $i : Integer
var $x; $y; $largeur; $hauteur : Real
$IDcadre:=0 // pour que le compilateur 4D n'oublie pas que ces variables existent
$IDcalque:=0
$numLogic:=0
$IDconnecteur:=0
$largeur:=0
$hauteur:=0
$IDconnexion:=$ptrIDconnexion->
// sélectionner le n° logique du connecteur à déplacer et le cadre de $1
This.LireEnregistrementBDD_AG(BDD_AG{connexions_ID}; "="; ->$IDconnexion; "-"; [BDD_AG{connexions_num_logic}; ->$numLogic; BDD_AG{connexions_cadre}; ->$IDcadre])
// lire le type élément et l'ID du calque du cadre
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$IDcadre; "-"; [BDD_AG{cadres_type_element}; ->$typeElement; BDD_AG{cadres_calque}; ->$IDcalque])
// lire la connexion suivante pour le rebouclage
$dataValue:=1
This.LireEnregistrementBDD_AG(BDD_AG{connexions_cadre_lie}; "="; ->$IDcadre; "*")
This.LireEnregistrementBDD_AG(BDD_AG{connexions_num_logic_lie}; "="; ->$dataValue; "ET")
$IDconnexion:=0
If (Size of array(indices)>0)
$IDconnexion:=BDD_AG{connexions_ID}->{indices{1}}
End if
// lire la connexion origine du calque
This.LireEnregistrementBDD_AG(BDD_AG{calques_ID}; "="; ->$IDcalque; "-"; [BDD_AG{calques_origine}; ->$OrigineCalque])
If ($IDconnexion#$OrigineCalque)
// on décale le connecteur $1 de $2 en x et $3 en y (cf "Deployer Cadre")
Case of
// autre union familiale
: ($typeElement=176)
This.trace.Error:=-16320*Num($numLogic=1)
This.trace.ErrorDescription:="Cadre "+String($IDcadre)+" de type 176 (autre conjoint) : le numLogic ne doit pas être égal à 1"
This.trace.LeverException(This.paramsArbre.optionsMsg)
// si le cadre du connecteur $1 est de type autre union :
// lire les dimensions du cadre courant
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$IDcadre; "-"; [BDD_AG{cadres_largeur}; ->$largeur; BDD_AG{cadres_hauteur}; ->$hauteur])
// décaler les connecteurs dont n° logique est $numLogic
// *** sélectionner les cadres concernés et lire la position réduite courante
ARRAY REAL($tabX_réduit; 0)
ARRAY REAL($tabY_réduit; 0)
This.LireEnregistrementBDD_AG(BDD_AG{connexions_cadre}; "="; ->$IDcadre; "*")
This.SelectionnerDansBDD_AG(BDD_AG{connexions_num_logic}; "="; ->$numLogic; "ET"; [BDD_AG{connexions_x_reduit}; ->$tabX_réduit; BDD_AG{connexions_y_reduit}; ->$tabY_réduit])
For ($i; 1; Size of array($tabX_réduit))
// *** calculer la nouvelle position réduite
$tabX_réduit{$i}:=(($x_delta+(($tabX_réduit{$i}+0.5)*$largeur))/($x_delta+$largeur))-0.5
$tabY_réduit{$i}:=(($y_delta+(($tabY_réduit{$i}+0.5)*$hauteur))/($y_delta+$hauteur))-0.5
End for
// mettre à jour
This.EcrireSelectionBDD_AG(->indices; [BDD_AG{connexions_x_reduit}; ->$tabX_réduit; BDD_AG{connexions_y_reduit}; ->$tabY_réduit])
// mettre à jour les dimensions du cadre
$largeur:=$largeur+$x_delta
$hauteur:=$hauteur+$y_delta
This.EcrireEnregistrementBDD_AG(BDD_AG{cadres_ID}; ->$IDcadre; [BDD_AG{cadres_largeur}; ->$largeur; BDD_AG{cadres_hauteur}; ->$hauteur])
// connecteur de Xcendance : cas particulier : c'est le premier connecteur du lien (NumLogic = 2)
: (($numLogic=2) & ($typeElement#256))
// décaler seulement le cadre
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$IDcadre; "-"; [BDD_AG{cadres_gauche}; ->$x; BDD_AG{cadres_haut}; ->$y])
$x:=$x+$x_delta
$y:=$y+$y_delta
This.EcrireEnregistrementBDD_AG(BDD_AG{cadres_ID}; ->$IDcadre; [BDD_AG{cadres_gauche}; ->$x; BDD_AG{cadres_haut}; ->$y])
// connecteur de Xcendance : cas normal
: ((($typeElement=224) | ($typeElement=256)) & ($numLogic>2))
// si le cadre du connecteur $1 est de type Xcendance et $1 est n'est pas le premier lien (n° logique du connecteur = 2) :
// décaler le connecteur $1 et augmenter d'autant la taille du cadre
// lire les dimensions du cadre courant
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$IDcadre; "-"; [BDD_AG{cadres_largeur}; ->$largeur; BDD_AG{cadres_hauteur}; ->$hauteur])
// garder la position absolue des connecteurs dont n° logique est >= 2 et < à celui qui crée la superposition
// *** lire la position réduite courante
ARRAY REAL($tabX_réduit; 0)
ARRAY REAL($tabY_réduit; 0)
$dataValue:=1
This.SelectionnerDansBDD_AG(BDD_AG{connexions_cadre}; "="; ->$IDcadre; "*")
This.SelectionnerDansBDD_AG(BDD_AG{connexions_num_logic}; ">"; ->$dataValue; "ET")
This.SelectionnerDansBDD_AG(BDD_AG{connexions_num_logic}; "<"; ->$numLogic; "ET"; [BDD_AG{connexions_x_reduit}; ->$tabX_réduit; BDD_AG{connexions_y_reduit}; ->$tabY_réduit])
For ($i; 1; Size of array($tabX_réduit))
// *** calculer la nouvelle position réduite
$tabX_réduit{$i}:=((($tabX_réduit{$i}+0.5)*$largeur)/($x_delta+$largeur))-0.5
$tabY_réduit{$i}:=((($tabY_réduit{$i}+0.5)*$hauteur)/($y_delta+$hauteur))-0.5
End for
// *** mettre à jour
This.EcrireSelectionBDD_AG(->indices; [BDD_AG{connexions_x_reduit}; ->$tabX_réduit; BDD_AG{connexions_y_reduit}; ->$tabY_réduit])
// décaler les connecteurs dont n° logique est >= à celui qui crée la superposition
// *** lire la position réduite courante
ARRAY REAL($tabX_réduit; 0)
ARRAY REAL($tabY_réduit; 0)
$dataValue:=2
This.SelectionnerDansBDD_AG(BDD_AG{connexions_cadre}; "="; ->$IDcadre; "*")
This.SelectionnerDansBDD_AG(BDD_AG{connexions_num_logic}; ">"; ->$dataValue; "ET")
This.SelectionnerDansBDD_AG(BDD_AG{connexions_num_logic}; ">="; ->$numLogic; "ET"; [BDD_AG{connexions_x_reduit}; ->$tabX_réduit; BDD_AG{connexions_y_reduit}; ->$tabY_réduit])
For ($i; 1; Size of array($tabX_réduit))
// *** calculer la nouvelle position réduite
$tabX_réduit{$i}:=(($x_delta+(($tabX_réduit{$i}+0.5)*$largeur))/($x_delta+$largeur))-0.5
$tabY_réduit{$i}:=(($y_delta+(($tabY_réduit{$i}+0.5)*$hauteur))/($y_delta+$hauteur))-0.5
End for
// *** mettre à jour
This.EcrireSelectionBDD_AG(->indices; [BDD_AG{connexions_x_reduit}; ->$tabX_réduit; BDD_AG{connexions_y_reduit}; ->$tabY_réduit])
// mettre à jour les dimensions du cadre
$largeur:=$largeur+$x_delta
$hauteur:=$hauteur+$y_delta
This.EcrireEnregistrementBDD_AG(BDD_AG{cadres_ID}; ->$IDcadre; [BDD_AG{cadres_largeur}; ->$largeur; BDD_AG{cadres_hauteur}; ->$hauteur])
// la suite le décalage est la moitié de l'élargissement du cadre
$x_delta:=$x_delta/2
$y_delta:=$y_delta/2
Else
ASSERT(cs._Trace.new().DebugerMethode("Déploiement"; Current method name; "Connexion "+String($1->)+" : ici, on ne peut pas avoir 'numLogic' = "+String($numLogic)+" et 'typeElement' = "+String($typeElement)))
End case
// suite des évènements
Case of
: ($typeElement=176)
// il n'y a rien au dessus => on s'arrête
Else
// continuer avec cadre du dessus appartenant au même calque
This.CalculerPositionBranche(->$IDconnexion; $x_delta; $y_delta)
End case
End if
Function CalculerPositionCadre($IDconnexion : Integer)->$result : Integer
var $IDcadre; $IDcadreParent; $typeElement : Integer
var $x; $y; $Xreduit; $Yreduit; $XreduitParent; $YreduitParent; $gauche; $haut; $largeur; $hauteur : Real
$IDcadreParent:=-1 // pour que le compilateur 4D n'oublie pas que ces variables existent
$Xreduit:=0
$Yreduit:=0
// calculer la position du connecteur amont de $IDconnexion
$IDcadre:=-1
Case of
// récupérer l'ID du cadre parent de $IDconnexion, les coordonnées réduites du connecteur parent $IDconnexion et celles du cadre lié
: (This.LireEnregistrementBDD_AG(BDD_AG{connexions_ID}; "="; ->$IDconnexion; "-"; [BDD_AG{connexions_cadre}; ->$IDcadreParent; BDD_AG{connexions_x_reduit}; ->$XreduitParent; BDD_AG{connexions_y_reduit}; ->$YreduitParent; BDD_AG{connexions_cadre_lie}; ->$IDcadre; BDD_AG{connexions_x_reduit_lie}; ->$Xreduit; BDD_AG{connexions_y_reduit_lie}; ->$Yreduit])=False)
// récupérer la position du cadre de $IDconnexion
: (This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$IDcadreParent; "-"; [BDD_AG{cadres_gauche}; ->$gauche; BDD_AG{cadres_haut}; ->$haut; BDD_AG{cadres_largeur}; ->$largeur; BDD_AG{cadres_hauteur}; ->$hauteur])=False)
Else
End case
// calculer la position de la connexion (elle n'est pas mémorisée en BDD_AG dans cette version)
$x:=$gauche+($largeur*(0.5+$XreduitParent))
$y:=$haut+($hauteur*(0.5+$YreduitParent))
// calculer la position du cadre
// trouver les dimensions du cadre à positionner
This.LireEnregistrementBDD_AG(BDD_AG{cadres_ID}; "="; ->$IDcadre; "-"; [BDD_AG{cadres_type_element}; ->$typeElement; BDD_AG{cadres_largeur}; ->$largeur; BDD_AG{cadres_hauteur}; ->$hauteur])
// mettre à jour l'enregistrement
$x:=$x-($largeur*(0.5+$Xreduit))
$y:=$y-($hauteur*(0.5+$Yreduit))
This.EcrireEnregistrementBDD_AG(BDD_AG{cadres_ID}; ->$IDcadre; [BDD_AG{cadres_gauche}; ->$x; BDD_AG{cadres_haut}; ->$y])
// renvoyer le cadre lié, sauf les cadres de lien consanguin
$result:=$IDcadre*Num(($typeElement#320))
$result:=Choose($typeElement=320; -1; $IDcadre)
// ----------------------
// MARK:Recherche BDD_AG
// ----------------------
Function LireEnregistrementBDD_AG($ptrTableau : Pointer; $opérateur : Text; $ptrValeur : Pointer; $associé : Text; $c : Collection)->$result : Boolean
var $tableaux : Collection
$tableaux:=This.CréerTableaux("tab"; "valeur"; $c)
$result:=This.SelectionnerDansTableauxBDD_AG($ptrTableau; $opérateur; $ptrValeur; $associé; $tableaux)
Function SelectionnerDansBDD_AG($ptrTableau : Pointer; $opérateur : Text; $ptrValeur : Pointer; $associé : Text; $c : Collection)->$result : Boolean
var $tableaux : Collection
$tableaux:=This.CréerTableaux("tab1"; "tab2"; $c)
$result:=This.SelectionnerDansTableauxBDD_AG($ptrTableau; $opérateur; $ptrValeur; $associé; $tableaux)
Function SelectionnerDansTableauxBDD_AG($ptrTableau : Pointer; $opérateur : Text; $ptrValeur : Pointer; $associé : Text; $tableaux : Collection)->$result : Boolean
var $i; $j : Integer
var $tableau : Object
This.trace.Initialiser(Current method name)
ARRAY LONGINT($indices; 0)
Case of
: (Length($associé)>2)
This.trace.ErrorDescription:="$associé est incorrect"
This.trace.Error:=-15068
: ($associé="-")
// lire un enregistrement
// lancer la sélection
This.trace.Error:=This.ChercherDansTableauxBDD_AG($ptrTableau; $opérateur; $ptrValeur; ->$indices)
// lire les données demandées
For each ($tableau; $tableaux)
// $tableau est un objet contenanr .tab ptr sur un tableau, .valeur une valeur
Case of
// la recherche doit être ok, ou pas d'erreur de typage
: (This.trace.Error#0)
// erreur précédemment, on passe
: ($tableau.length<2)
This.trace.Error:=-15068
This.trace.ErrorDescription:="Nombre de paramètres insuffisant"
: (Not(OB Is defined($tableau; "tab")))
This.trace.Error:=-15068
This.trace.ErrorDescription:="attribut 'tab' non défini"
: (Not(OB Is defined($tableau; "valeur")))
This.trace.Error:=-15068
This.trace.ErrorDescription:="attribut 'valeur' non défini"
// ${$i} et ${$i+1} doivent être du même type
: ((Type($tableau.tab->)=LongInt array) & (Type($tableau.valeur->)#Is longint))
This.trace.Error:=-15068
This.trace.ErrorDescription:="Erreur de typage d'une valeur recherchée"
: ((Type($tableau.tab->)=Real array) & (Type($tableau.valeur->)#Is real))
This.trace.Error:=-15068
: ((Type($tableau.tab->)=Boolean array) & (Type($tableau.valeur->)#Is boolean))
This.trace.Error:=-15068
Else
// c'est ok
If (Size of array($indices)=1)
// renvoyer la valeur demandée de l'enregistrement
$tableau.valeur->:=$tableau.tab->{$indices{1}}
Else
// émuler SQL : ne pas générer d'erreur et effacer la variable
CLEAR VARIABLE($tableau.valeur->)
End if
End case
End for each
Else
// sélection d'enregistrements
If ($opérateur="IN")
// cas d'une JOINTURE $ptrTableau $ptrValeur (on fait simple : ne traite que des ID)
This.trace.Error:=-15068
Case of
// il faut un champ ID
: (Type($ptrTableau->)#LongInt array)
This.trace.ErrorDescription:="Jointure : $ptrTableau n'est pas un tableau d'ID"
// il faut une sélection d'ID
: (Type($ptrValeur->)#LongInt array)
This.trace.ErrorDescription:="Jointure : $ptrValeur n'est pas un tableau d'ID"
Else
// c'est ok
This.trace.Error:=0
// sélectionner les éléments de $ptrTableau dont la valeur est dans $ptrValeur
ARRAY LONGINT($tableauOUT; 0)
For ($i; 1; Size of array($ptrValeur->))
// il peut y avoir plusieurs valeurs
$j:=0
Repeat
$j:=Find in array($ptrTableau->; $ptrValeur->{$i}; $j+1)
If ($j>0)
INSERT IN ARRAY($tableauOUT; Size of array($tableauOUT)+1)
$tableauOUT{Size of array($tableauOUT)}:=$j
End if
Until ($j=-1)
End for
ARRAY LONGINT(indices; 0)
COPY ARRAY($tableauOUT; indices)
End case
Else
// initialiser ou affiner la sélection
This.trace.Error:=This.ChercherDansTableauxBDD_AG($ptrTableau; $opérateur; $ptrValeur; ->$indices)
Case of
: (This.trace.Error#0)
: ($associé="*")
// début d'une sélection multi critères
ARRAY LONGINT(indices; 0)
COPY ARRAY($indices; indices)
: ($associé="ET")
// intersection de la sélection courante avec "indices"
ARRAY LONGINT($tableauOUT; 0)
// peu importe le tableau utilisé par la boucle
For ($i; 1; Size of array($indices))
If (Find in array(indices; $indices{$i})>0)
INSERT IN ARRAY($tableauOUT; Size of array($tableauOUT)+1)
$tableauOUT{Size of array($tableauOUT)}:=$indices{$i}
End if
End for
COPY ARRAY($tableauOUT; indices)
: ($associé="OU")
// somme de la sélection courante avec $5
// optimisation façon 4D (cf forum4D)
//$tableauIN:=$5
//INSÉRER DANS TABLEAU($indices;Taille tableau($indices)+1;Taille tableau($tableauIN))
// //....
//COPIER TABLEAU($indices;$5->)
Else
This.trace.Error:=-16350
This.trace.ErrorDescription:=$associé+": cet opérateur n'est pas traité"
End case
End if
// extraire les infos ${5+i} de la sélection courante dans ${6+i}
Case of
: (Count parameters<5)
: ($tableaux=Null)
: ($tableaux.length=0)
Else
This.trace.Error:=-15068
This.trace.ErrorDescription:="Erreur de typage d'une valeur recherchée"
For each ($tableau; $tableaux)
Case of
// il doit y avoir encore des paramètres
: ($tableau.length<2)
This.trace.ErrorDescription:="Nombre de paramètres insuffisant"
: (Not(OB Is defined($tableau; "tab1")))
This.trace.ErrorDescription:="attribut 'tab1' non défini"
: (Not(OB Is defined($tableau; "tab2")))
This.trace.ErrorDescription:="attribut 'tab2' non défini"
// ${$i} et ${$i+1} doivent être du même type
: ((Type($tableau.tab1->)=LongInt array) & (Type($tableau.tab2->)#LongInt array))
: ((Type($tableau.tab1->)=Real array) & (Type($tableau.tab2->)#Real array))
: ((Type($tableau.tab1->)=Boolean array) & (Type($tableau.tab2->)#Boolean array))
Else
// c'est ok
This.trace.Error:=0
// émuler SQL : si sélection vide, ne pas générer d'erreur et renvoyer un tableau vide
CLEAR VARIABLE($tableau.tab2->)
If (Size of array(indices)>0)
INSERT IN ARRAY($tableau.tab2->; 1; Size of array(indices))
// renvoyer la valeur demandée des enregistrements
For ($j; 1; Size of array(indices))
$tableau.tab2->{$j}:=$tableau.tab1->{indices{$j}}
End for
End if
End case
End for each
End case
End case
This.trace.FixerSuccess()
This.trace.LeverException(This.paramsArbre.optionsMsg)
$result:=This.trace.success
Function ChercherDansTableauxBDD_AG($ptrTableau : Pointer; $opérateur : Text; $ptrValeur : Pointer; $ptrSélection : Pointer)->$result : Integer
var $numTable; $numChamp; $i : Integer
var $VarName : Text
This.trace.Initialiser(Current method name)
This.trace.Error:=-15068
This.trace.ErrorDescription:="$ptrTableau et $ptrValeur ne sont pas du même type"
RESOLVE POINTER($ptrTableau; $VarName; $numTable; $numChamp)
Case of
// il faut un sous tableau de tableau 2D
: (($numTable=0) | ($numChamp#-1))
This.trace.ErrorDescription:="$ptrTableau doit être un tabeau 2D"
// tous les types ne sont pas traités
: ((Not(Type($ptrTableau->)=LongInt array)) & (Not(Type($ptrTableau->)=Real array)) & (Not(Type($ptrTableau->)=Boolean array)))
This.trace.ErrorDescription:="$ptrTableau doit être un tableau d'entiers longs, ou de réels ou de booléens"
// il faut un opérateur
: (Length($opérateur)>2)
This.trace.ErrorDescription:="$opérateur est incorrect"
// $ptrTableau et $ptrValeur doivent être du même type
: ((Type($ptrTableau->)=LongInt array) & (Type($ptrValeur->)#Is longint))
: ((Type($ptrTableau->)=Real array) & (Type($ptrValeur->)#Is real))
: ((Type($ptrTableau->)=Boolean array) & (Type($ptrValeur->)#Is boolean))
Else
RESOLVE POINTER($ptrSélection; $VarName; $numTable; $numChamp)
Case of
// il faut un tableau en sortie
: (($numTable#-1) | ($numChamp#-1))
// il faut toujours un tableau de type entier long (= indices)
: (Type($ptrSélection->)#LongInt array)
Else
This.trace.Error:=0
// on y va
CLEAR VARIABLE($ptrSélection->)
Case of
: ($opérateur="=")
For ($i; 1; Size of array($ptrTableau->))
If ($ptrTableau->{$i}=$ptrValeur->)
APPEND TO ARRAY($ptrSélection->; $i)
End if
End for
: ($opérateur="#")
For ($i; 1; Size of array($ptrTableau->))
If ($ptrTableau->{$i}#$ptrValeur->)
APPEND TO ARRAY($ptrSélection->; $i)
End if
End for
: ($opérateur=">")
For ($i; 1; Size of array($ptrTableau->))
If ($ptrTableau->{$i}>$ptrValeur->)
APPEND TO ARRAY($ptrSélection->; $i)
End if
End for
: ($opérateur="<")
For ($i; 1; Size of array($ptrTableau->))
If ($ptrTableau->{$i}<$ptrValeur->)
APPEND TO ARRAY($ptrSélection->; $i)
End if
End for
: ($opérateur=">=")
For ($i; 1; Size of array($ptrTableau->))
If ($ptrTableau->{$i}>=$ptrValeur->)
APPEND TO ARRAY($ptrSélection->; $i)
End if
End for
Else
This.trace.Error:=-16350
This.trace.ErrorDescription:=$opérateur+": cet opérateur n'est pas traité"
End case
End case
End case
This.trace.LeverException(This.paramsArbre.optionsMsg)
$result:=This.trace.Error
// ----------------------
// MARK:Ecriture dans BDD_AG
// ----------------------
Function EcrireEnregistrementBDD_AG($ptrTableau : Pointer; $ptrValeur : Pointer; $c : Collection)->$result : Integer
var $i : Integer
This.trace.Initialiser(Current method name)
This.trace.Error:=-15068
Case of
// il faut un minimum de paramètres
: (Count parameters<3)
This.trace.ErrorDescription:="les données à enregister sont manquantes"
: (Mod($c.length; 2)#0)
This.trace.ErrorDescription:="les paires 'tableau' 'valeur' sont incomplètes"
Else
This.trace.Error:=0
// mettre à jour un enregistrement
// sélectionner l'enregistrement dans la table de $ptrTableau
ARRAY LONGINT($indices; 0)
This.trace.Error:=This.ChercherDansTableauxBDD_AG($ptrTableau; "="; $ptrValeur; ->$indices)
This.trace.ErrorDescription:="enregistrement non trouvé"
// écrire les valeurs
For ($i; 0; $c.length-1; 2)
Case of
: (This.trace.Error#0)
// erreur précédemment
$i:=$c.length
: (Size of array($indices)=0)
// on n'a pas d'enregistrement
// $c[$i] et $c[$i+1] doivent être du même type
: ((Type($c[$i]->)=LongInt array) & (Type($c[$i+1]->)#Is longint))
This.trace.Error:=-15068
This.trace.ErrorDescription:="tableau et valeur ne sont pas du même type 'entier long'"
: ((Type($c[$i]->)=Real array) & (Type($c[$i+1]->)#Is real))
This.trace.Error:=-15068
This.trace.ErrorDescription:="tableau et valeur ne sont pas du même type 'numerique'"
: ((Type($c[$i]->)=Boolean array) & (Type($c[$i+1]->)#Is boolean))
This.trace.Error:=-15068
This.trace.ErrorDescription:="tableau et valeur ne sont pas du même type 'boolean'"
Else
// c'est ok
// écrire la valeur demandée de l'enregistrement
$c[$i]->{$indices{1}}:=$c[$i+1]->
End case
End for
End case
This.trace.FixerSuccess()
This.trace.LeverException(This.paramsArbre.optionsMsg)
$result:=This.trace.Error
Function EcrireSelectionBDD_AG($ptrIndices : Pointer; $c : Collection)->$result : Integer
var $i; $j : Integer
This.trace.Initialiser(Current method name)
This.trace.Error:=-15068
ARRAY LONGINT($indices; 0)
Case of
// il faut un minimum de paramètres
: (Count parameters<2)
This.trace.ErrorDescription:="les données à enregister sont manquantes"
: (Mod($c.length; 2)#0)
This.trace.ErrorDescription:="les paires 'tableau' 'tableau' sont incomplètes"
: (Type($ptrIndices->)#LongInt array)
This.trace.ErrorDescription:="$ptrIndices ne pointe pas un tableau d'indices"
// le tableau n'est pas un tableau d'indices
: (Size of array($ptrIndices->)=0)
This.trace.ErrorDescription:="le tableau $ptrIndices est vide"
Else
// c'est ok
This.trace.Error:=0
//%W-518.1
COPY ARRAY($ptrIndices->; $indices)
//%W+518.1
For ($i; 0; $c.length-1; 2)
Case of
// pas d'erreur de typage
: (This.trace.Error#0)
// erreur précédemment
$i:=$c.length
// ${$i} et ${$i+1} doivent être du même type
: ((Type($c[$i]->)=LongInt array) & (Type($c[$i+1]->)#LongInt array))
This.trace.Error:=-15068
This.trace.ErrorDescription:="tableau et valeur ne sont pas du même type 'entier long'"
: ((Type($c[$i]->)=Real array) & (Type($c[$i+1]->)#Real array))
This.trace.Error:=-15068
This.trace.ErrorDescription:="tableau et valeur ne sont pas du même type 'numerique'"
: ((Type($c[$i]->)=Boolean array) & (Type($c[$i+1]->)#Boolean array))
This.trace.Error:=-15068
This.trace.ErrorDescription:="tableau et valeur ne sont pas du même type 'boolean'"
Else
// c'est ok
// écrire les valeurs demandée de l'enregistrement
For ($j; 1; Size of array($indices))
$c[$i]->{$indices{$j}}:=$c[$i+1]->{$j}
End for
End case
End for
End case
This.trace.FixerSuccess()
This.trace.LeverException(This.paramsArbre.optionsMsg)
$result:=This.trace.Error
// ----------------------
// MARK:Utilitaires
// ----------------------
Function CréerTableaux($attribut1 : Text; $attribut2 : Text; $c : Collection)->$result : Collection
// créer la collection d'objets à partir de la collection de pointeur $c
// chaque objet a un attribut $attribut1, valeur $c[$i], et un attribut $attribut2, valeur $c[$i+1]
var $i : Integer
$result:=New collection
Case of
: ($c=Null)
: ($c.length=0)
: (Mod($c.length; 2)#0)
Else
For ($i; 0; $c.length-1; 2)
$result.push(New object($attribut1; $c[$i]; $attribut2; $c[$i+1]))
End for
End case
⇧
[class]Sites - 13/01/2025 12:48:56
Class extends _ARB_DataStore
Class constructor($IDentité : Variant)
// initialiser l'objet avec les données de l'entité $IDunique de la BDD
Super("Sites"; $IDentité)
⇧
[class]_ARB_DataStore - 29/05/2025 12:48:27
property fct : Object
property selection : Collection
property length : Integer
property DataClassNom : Text:=""
property collection : Collection
Class constructor($DataClassNom : Text; $data : Variant)
Super()
This.fct:=cs.xSQL[$DataClassNom].new($data)
// récupérer les attributs scalaires dans this : .DataClassNom, .collection et .length
cs.xSDK.Outils.me.CopierAttributs(This.fct; This)
// ----------------------
//MARK:Entité Wrappers
// ----------------------
Function Libellé($formats : Object)->$libellé : Text
// renvoie le nom formaté de this suivant les options $formats
$libellé:=This.fct.Libellé($formats)
Function Le($DataClassNom : Text)->$result : Object
// renvoie l'entité [$DataClassNom] de ce composant (la classe doit exister !)
var $entité : Object
$entité:=This.fct.Le($DataClassNom)
// ajouter les attributs / functions WEB
$result:=cs[$DataClassNom].new($entité.ID)
Function IDcodé()->$result : Integer
$result:=This.fct.IDcodé()
// ----------------------
//MARK:Sélections
// ----------------------
Function Créer()
// créer une collection d'entités ; resultat dans .selection
This.setEntités()
Function setEntités()
// créer la sélection (collection d'entités de this)
var $ID : Integer
This.selection:=New collection
Case of
: (This.DataClassNom="")
: (Not(OB Is defined(This; "collection")))
: (This.collection.length=0)
Else
For each ($ID; This.collection)
This.selection.push(cs[This.DataClassNom].new($ID))
End for each
This.length:=This.selection.length
End case
Function getRelatedEntity($chemin : Text)->$entité : Object
var $c : Collection
var $dataTexte; $lien : Text
// remonter le chemin $chemin de this
$dataTexte:=$chemin
If ($dataTexte="@_@")
$c:=Split string($dataTexte; "_")
// nom de l'attribut de l'end entité
$dataTexte:=$c.pop()
$entité:=This
For each ($lien; $c)
$entité:=$entité[$lien]
End for each
Else
$entité:=This
End if
⇧
[class]_modification_modele_AG - 09/02/2026 10:08:56
property typeElement : Text
// cette classe gère l'IHM de modification de l'arbre
Class extends _composant
Class constructor()
Super()
// ----------------------
// MARK:Modifier modèle AG
// ----------------------
Function Redimensionner($ID_SVG : Text; $largeur : Integer; $hauteur : Integer)
var $functionID : Text
var $c : Collection
$c:=Split string($ID_SVG; "_")
$functionID:="errFunction"
Case of
: ($c.length=0)
: (This.paramsArbre.EtatProcessus.Params ?? 0)
$functionID:="ModifierDimensionsType"+$c[$c.length-1]
: (This.paramsArbre.EtatProcessus.Params ?? 1)
$functionID:="ModifierDimensions"+$c[$c.length-1]
End case
If (OB Is defined(This; $functionID))
This[$functionID]($largeur; $hauteur)
End if
Function ModifierDimensionsTypeCadreElement($largeur : Integer; $hauteur : Integer)
// fixer dans le modèle de l'arbre les nouvelles dimensions de l'élément de type de celui sélectionné
var $racineXMLmodele; $elementXMLmodele; $elementXML : Text
// le parent de "SelectedElementID_SVG" contient le type de l'élément
If (This.LireTypeElement())
$racineXMLmodele:=This.LireModeleArbre()
$elementXMLmodele:=DOM Find XML element by ID($racineXMLmodele; This.typeElement)
$elementXML:=DOM Find XML element($elementXMLmodele; "deploiement/largeur")
If (ok=1)
DOM SET XML ELEMENT VALUE($elementXML; $largeur)
End if
$elementXML:=DOM Find XML element($elementXMLmodele; "deploiement/hauteur")
If (ok=1)
DOM SET XML ELEMENT VALUE($elementXML; $hauteur)
End if
This.FixerModeleArbre($racineXMLmodele)
End if
Function AjouterInformation($propriété : Text; $valeur : Text)
// copier le template $3 de "DataARB.xml" dans le modèle de l'élément du cadre IDBDDcodé = $2
var $racineXMLmodele; $elementXML; $xPath; $elementXMLmodele
var $fichier; $RacineXML : Text
Case of
: (Form.EtatProcessus.SelectedElementID_SVG="")
// il manque l'ID de l'élément à modifier
: (Not(This.LireTypeElement()))
Else
This.trace.Initialiser(Current method name)
This.OuvrirBDD_Externe()
$racineXMLmodele:=This.LireModeleArbre()
// élémentXML à modifier dans le modèle
$elementXML:=DOM Find XML element by ID($racineXMLmodele; This.typeElement)
$xPath:="informationsList"
$elementXMLmodele:=DOM Find XML element($elementXML; $xPath)
If (ok=0)
$elementXMLmodele:=DOM Create XML element($elementXML; $xPath)
End if
If (ok=1)
// élément à copier
$fichier:=Folder(fk resources folder).file("DataARB.xml").platformPath
$RacineXML:=DOM Parse XML source($fichier)
$elementXML:=DOM Find XML element by ID($racineXML; $valeur)
$elementXML:=DOM Get first child XML element($elementXML)
If (ok=1)
// copier
$elementXMLmodele:=DOM Append XML element($elementXMLmodele; $elementXML)
This.trace.Error:=-16311*Num(ok=0)
This.trace.ErrorDescription:="Ajout impossible d'une information au modèle"
Else
This.trace.Error:=-16312
This.trace.ErrorDescription:="Element "+$valeur+" absent dans le modèle de l'arbre"
End if
DOM CLOSE XML($RacineXML)
Else
This.trace.Error:=-16313
This.trace.ErrorDescription:="le template de "+This.typeElement+" est absent dans le fichier <DataARB.xml>"
End if
// enregister le modèle dans l'arbre
If (This.trace.Error=0)
This.EcrireModeleArbre($racineXMLmodele)
End if
This.FermerBDD_Externe()
End case
Function ModifierDimensionsCadreElement($largeur : Integer; $hauteur : Integer)
// fixer dans le modèles de l'arbre les nouvelles dimensions de l'élément sélectionné
ALERT(Current method name+" : Commande "+Current method name+" modifier la BDD_AG pas faite")
TRACE // pas fait
Function ModifierFormatTypeCadreInformation($propriété : Text; $valeur : Text)
TRACE
// ----------------------
// MARK:Utiliser modèle AG
// ----------------------
Function FixerModeleArbre($racineXMLmodele : Text)
// copier le modèle dans la BDD_AG
var $dataTexte : Text
var $IDarbre : Integer
DOM EXPORT TO VAR($racineXMLmodele; $dataTexte)
$IDarbre:=This.paramsArbre.IDarbre
Begin SQL
START TRANSACTION;
UPDATE arbres SET modele = :$dataTexte WHERE id = :$IDarbre;
COMMIT TRANSACTION;
End SQL
DOM CLOSE XML($racineXMLmodele)
Function ExporterModele()
// enregistrer le modèle de l'arbre (par exemple après modification)
var $IDarbre : Integer
var $dataTexte; $nomDossier : Text
var $fichier : Object
// demander le nom du modèle
This.OuvrirFormulaireSaisie(3510)
$dataTexte:="chaines/nomDossierModeles"
$nomDossier:=""
Case of
: (Form.texteSaisi="")
// annulation par utilisateu
: (Not(This.rsc.SetVariable(Est Ressource ARB; $dataTexte; Is text; ->$nomDossier)))
// erreur lecture
Else
// v10.3.8 : les BDD externes sont fermées après chaque traitement ; la réouvrir
This.OuvrirBDD_Externe()
$IDarbre:=Form.paramsArbre.IDarbre
Begin SQL
SELECT modele FROM arbres WHERE arbres.id = :$IDarbre INTO :$dataTexte;
End SQL
This.FermerBDD_Externe()
$fichier:=Folder(fk resources folder).folder($nomDossier)
$fichier.create() // au cas où!
$fichier:=$fichier.file(Form.texteSaisi+".xml")
TEXT TO DOCUMENT($fichier.platformPath; $dataTexte)
End case
// ----------------------
// MARK:Utilitaires
// ----------------------
Function OuvrirFormulaireSaisie($libellé : Integer)
var $wndNum : Integer
Form.titreSaisi:=Localized string("3501")+Localized string(String($libellé))
Form.texteSaisi:=""
$wndNum:=Open form window("Saisie"; Sheet form window)
DIALOG("Saisie"; Form)
Form.texteSaisi:=Form.texteSaisi*Num(Ok=1)
CLOSE WINDOW
Function LireModeleArbre()->$result : Text
var $IDarbre : Integer
var $dataTexte : Text
$IDarbre:=This.paramsArbre.IDarbre
Begin SQL
SELECT modele FROM arbres WHERE id = :$IDarbre INTO :$dataTexte;
End SQL
$result:=DOM Parse XML variable($dataTexte)
Function EcrireModeleArbre($racineXMLmodele : Text)
var $IDarbre : Integer
var $dataTexte : Text
DOM EXPORT TO VAR($racineXMLmodele; $dataTexte)
DOM CLOSE XML($racineXMLmodele)
$IDarbre:=This.paramsArbre.IDarbre
Begin SQL
START TRANSACTION;
UPDATE arbres SET modele=:$dataTexte WHERE id = :$IDarbre;
COMMIT TRANSACTION;
End SQL
Function LireTypeElement()->$result : Boolean
// écrire dans Form le type d'élément de l'élément courant sélectionné
var $ID : Text
This.typeElement:=""
$result:=False
// le parent de "SelectedElementID_SVG" contient le type de l'élément
$ID:=DOM Find XML element by ID(arbreDOM; This.paramsArbre.EtatProcessus.SelectedElementID_SVG)
If (ok=1)
$ID:=DOM Get parent XML element($ID)
If (ok=1)
DOM GET XML ATTRIBUTE BY NAME($ID; "typeElement"; $ID)
$result:=(ok=1)
End if
End if
This.typeElement:=$ID
⇧
[class]_composant - 08/02/2026 10:41:25
property environnement : cs.xSDK.EnvironnementALV
property paramsArbre : Object
property sql_BDDpath : 4D.Folder
property trace : cs._Trace
property fct : cs.xSDK.Outils
property rsc : cs.xSDK.ResourceALV
Class constructor()
// environnement
This.environnement:=cs.xSDK.EnvironnementALV.new()
This.paramsArbre:=New object
This.sql_BDDpath:=Null
This.trace:=cs._Trace.me
This.fct:=cs.xSDK.Outils.me
This.rsc:=cs.xSDK.ResourceALV.me
// ----------------------
// MARK:Installation
// ----------------------
Function InitVariablesARB()
// pour les tests hors base hôte
Use (Storage)
Storage.System:=New shared object
Storage.Host:=New shared object
End use
Use (Storage.System)
Storage.System.Status:=0
Storage.System.EstExecuteDansHote:=False
Storage.System.typeApplication:=This.environnement.typeApplication()
Storage.System.estServeur:=This.environnement.estServeur()
Storage.System.estClient:=This.environnement.estClient()
End use
This.rsc.Inscrire(Est Ressource ARB; New object("chemin"; Folder(fk resources folder).file("DataARB.xml").platformPath))
Function Installer()
Use (Storage.System)
Storage.System.estExecuteDansAPP:=cs.xSDK.EnvironnementALV.new().estExecuteDansAPP()
End use
This.InstallerDonnéesHote()
This.InstallerRessources()
Function InstallerDonnéesHote()
// lire les données d'installation
var $attribut : Text
var $data : Object
Case of
: (Not(Storage.System.EstExecuteDansHote))
// exécution du composant en local
: (Not(Storage.System.estExecuteDansAPP))
// exécution du composant dans un composant
: (Storage.System.typeApplication=ALV Client APP)
: (Storage.System.typeApplication=4D Remote mode)
// filtrer
Else
$data:=New object
EXECUTE METHOD(Modifier la DataStore; $data)
// recopier les données reçues
Use (Storage.Host)
For each ($attribut; OB Keys($data))
Storage.Host[$attribut]:=$data[$attribut]
End for each
End use
End case
Function InstallerRessources()
// vérifier qu'il y a des modèles dans la base hôte (les créer au besoin)
var $dossier : 4D.Folder
var $nomDossier : Text
$dossier:=This.getDossierModelesAG()
If ($dossier.files(fk ignore invisible).length=0) // y mettre les modèles par défaut
$nomDossier:=""
If (This.rsc.SetVariable(Est Ressource ARB; "chaines/nomDossierModeles"; Is text; ->$nomDossier)) // nom du dossier des modèles
// chemin du dossier des modèles du composant
$dossier:=Folder(fk resources folder).folder($nomDossier)
COPY DOCUMENT($dossier.platformPath; Get 4D folder(Current resources folder; *)) // attention copie les documents et le dossier
End if
End if
// ----------------------
// MARK:BDD AG
// ----------------------
Function OuvrirBDD_Externe()
// Ouvrir (ou créer si elle n'existe pas) une BDD externe, via SQL
var $result : cs._Trace
var $sql_BDDpath; $sql_BDDcourantePath; $texte : Text
var $table; $champ : Object
$result:=This.trace.Initialiser(Current method name)
This.FixerParametresBDD_AG()
Case of
: (Not(OB Is defined(This; "paramsArbre")))
$result.ErrorDescription:="paramsArbre n'est pas défini dans this"
: (Not(OB Is defined(This.paramsArbre; "sql_BDDpath")))
$result.ErrorDescription:="sql_BDDpath n'est pas défini dans this.paramsArbre"
Else
// ok on a tout
$result.Error:=0
// fixer le nom de la BDD externe ouvrir
$sql_BDDpath:=This.paramsArbre.sql_BDDpath
// lire la BDD externe ouverte
$sql_BDDcourantePath:=""
Begin SQL
SELECT DATABASE_PATH() FROM _USER_SCHEMAS LIMIT 1 INTO :$sql_BDDcourantePath;
End SQL
If (Position("/"; $sql_BDDcourantePath)>0)
$sql_BDDcourantePath:=Convert path POSIX to system($sql_BDDcourantePath)
End if
Case of
: ($sql_BDDpath+".4DB"=$sql_BDDcourantePath)
// déjà ouverte, ne rien faire
: (Test path name($sql_BDDpath+".4DB")=Is a document)
// ouverture d'une BDD existante
Begin SQL
USE DATABASE DATAFILE :$sql_BDDpath;
End SQL
// attention ici on est thread-safe
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; "Process "+Current process name; Current method name; "Ouverture de '"+$sql_BDDpath+"'"; New object("nomProcess"; Current process name; "numProcess"; Current process))
Else
Waiting(30)
// nouvelle BDD externe
//-- créer les fichiers $fichier.4DB et $fichier.4DD
//-- créer / mettre à jour la structure
//-- créer les index
//-- envoyer les requêtes SQL vers la BDD externe
// créer la commande de création de la structure
Case of
: (Not(OB Is defined(This.paramsArbre; "parametresBDD")))
$result.Error:=-15063
$result.ErrorDescription:="parametresBDD n'est pas défini"
: (Not(OB Is defined(This.paramsArbre.parametresBDD; "structure")))
$result.Error:=-15063
$result.ErrorDescription:="structure n'est pas défini dans parametresBDD"
: (This.paramsArbre.parametresBDD.structure.length=0)
$result.Error:=-15063
$result.ErrorDescription:="structure de parametresBDD est vide"
Else
Begin SQL
CREATE DATABASE IF NOT EXISTS DATAFILE :$sql_BDDpath;
USE DATABASE DATAFILE :$sql_BDDpath;
End SQL
For each ($table; This.paramsArbre.parametresBDD.structure)
// on a une table
Case of
: (Not(OB Is defined($table; "nomTable")))
: (Not(OB Is defined($table; "champs")))
: ($table.champs.length=0)
Else
// ok on a une table et ses champs
$texte:="CREATE TABLE IF NOT EXISTS "+$table.nomTable
// lister les champs
$texte:=$texte+" ("
For each ($champ; $table.champs)
$texte:=$texte+$champ.champ+" "+$champ.type+", "
End for each
// fermer
$texte:=Substring($texte; 1; Length($texte)-2)+");"
End case
Begin SQL
EXECUTE IMMEDIATE :$texte;
End SQL
// id automatique
$texte:="ALTER TABLE "+$table.nomTable+" MODIFY id ENABLE AUTO_INCREMENT;"
Begin SQL
EXECUTE IMMEDIATE :$texte;
End SQL
End for each
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; "Process "+Current process name; Current method name; "Création de '"+$sql_BDDpath+"'"; New object("nomProcess"; Current process name; "numProcess"; Current process))
End case
End case
// Maintenant toutes les requêtes SQL du process sont dirigées vers $sql_BDDpath
End case
$result.LeverException(This.paramsArbre.optionsMsg)
Function FermerBDD_Externe()
// fermer la base
Begin SQL
USE DATABASE SQL_INTERNAL;
End SQL
// ----------------------
// MARK:Document
// ----------------------
// Les documents utilisateurs sont : les BDD_AG créées et les modèles AG.
// Les modèles AG sont dans des dossiers de la base hôte (ou du composant en développement) : ils ne sont pas effacés à la mise à jour du composant dans la base hôte
// Les BDD_AG sont par défaut dans un dossier au même niveau que le dossier des fichiers données de la base hôte (ou du composant en développement). Le dossier par défaut est modifiable via $1
Function getDossierModelesAG()->$result : 4D.Folder
// renvoyer le chemin du dossier où sont rangées tous les modèles
var $nomDossier; $xPath : Text
$nomDossier:=""
$xPath:="chaines/nomDossierModeles"
If (This.rsc.SetVariable(Est Ressource ARB; "chaines/nomDossierModeles"; Is text; ->$nomDossier)) // nom du dossier des modèles
// le dossier est installée au même niveau que les ressources de la base hôte (ou du composant en développement)
$result:=Folder(fk resources folder; *).folder($nomDossier)
Else
$result:=Null
End if
Function FixerSQL_BDDpath()
// fixer le nom sql de la BDD AG
// * fixer le dossier de la BDD_AG (données base hôte)
var $dossier : Object
var $fichier : 4D.File
var $nom : Text
$dossier:=Null
Case of
: (OB Is defined(This.paramsArbre; "LogIn"))
$dossier:=Storage.Host.$document.call(Null).GetSessionFolderOnServer(This.paramsArbre.LogIn)
: (OB Is defined(This.paramsArbre; "CheminDossierBDD_AG"))
// ok on prend ça (cas des serveurs Web en particulier)
$dossier:=Folder(This.paramsArbre.CheminDossierBDD_AG; fk platform path)
Else
End case
// si erreur, utiliser le dossier par défaut
// le dossier est installée au même niveau que les fichiers données de la base hôte (ou du composant en développement)
Case of
: ($dossier=Null)
$dossier:=File(Data file; fk platform path).parent.parent
: (Not($dossier.exists))
$dossier:=File(Data file; fk platform path).parent.parent
End case
// les BDD_AG sont dans un sous dossier spécifique
$nom:=""
If (This.rsc.SetVariable(Est Ressource ARB; "chaines/nomDossierBDDs_AG"; Is text; ->$nom)) // nom du dossier des BDDs AG
// utiliser ce sous dossier
$dossier:=$dossier.folder($nom)
End if
// * fixer le nom de la BDD_AG
This.sql_BDDpath:=Null
If (This.paramsArbre.nomBDD=Null)
$nom:="AG_"+String(This.paramsArbre.IDpersonne & 0x00FFFFFF) // nom de la BDD (dossier .4dbase)
Else
$nom:=This.paramsArbre.nomBDD
End if
// * chemin de la BDD_AG
// "Arbres_Genealogiques" = nom sql de la BDD
$fichier:=$dossier.folder($nom+".4dbase").file("Arbres_Genealogiques")
$fichier.create()
This.paramsArbre.sql_BDDpath:=$fichier.platformPath
// ----------------------
// MARK:BDD_AG
// ----------------------
Function FixerParametresBDD_AG()
// si besoin, installer le dossier de la BDD_AG
This.FixerSQL_BDDpath()
// fixer les paramètres de la structure de la BDD, au cas où besoin de créer la BDD
This.paramsArbre.parametresBDD:=New object
This.paramsArbre.parametresBDD.cheminStructure:=Folder(fk resources folder).folder("Enumérations").file("Structure_BDD_AG.json").platformPath
This.paramsArbre.parametresBDD.structure:=JSON Parse(Document to text(This.paramsArbre.parametresBDD.cheminStructure))
// ----------------------
// MARK:Utilitaires
// ----------------------
Function InitProcess()
var $texte : Text
ProcInProgressNum:=0
ProcInProgressTime:=0
AsynchroProgress:=0
ErrorNum:=0
ON ERR CALL(Formula(traceHandler).source) // gestion des erreurs
$texte:=cs.xSDK.Outils.me.getTextDeTypeProcess(Current process)
cs._Trace.me.EnvoyerMessages([msgk_event; msgk_log]; "Information"; Current method name; $texte)
Function InitResult($Error : Integer; $ErrorDescription : Text)->$result : Object
If (Count parameters=0)
$result:=New object("Error"; 0; "ErrorDescription"; ""; "success"; True)
Else
$result:=New object("Error"; $Error; "ErrorDescription"; $ErrorDescription; "success"; True)
End if
⇧
[class]$arbre - 01/08/2026 13:13:08
property racineXML : Text
property menu : cs._menus
property Navigation : Object
property SubFormContainer : Object:=Null
Class extends _composant
Class constructor($params : Object; $host : Object)
Super()
This.paramsArbre.EtatProcessus:=New object
This.racineXML:=""
This.SubFormContainer:=Null
If (Count parameters>0)
This.paramsArbre:=$params
End if
// init locale
This.paramsArbre.EtatProcessus.ID_SVG:=""
If (Count parameters>1)
This.SubFormContainer:=$host
End if
This.menu:=cs._menus.new(This.paramsArbre; This.SubFormContainer)
// ----------------------
// MARK:Entrées base hôte
// ----------------------
Function Afficher_AG($params : Object)
// ici on est dans le process appelant
If (This._ValiderParams($params).success)
CALL WORKER("WK_ArbreGenealogie"; Formula from string("cs.$arbre.new($1).Créer_AG()"); $params)
End if
Function Imager_AG($params : Object)
// on est toujours dans BDDmère ou serveur APP
var $durée : Integer
If (This._ValiderParams($params).success)
// créer le trigger pour le retour
$params.finDeTâche:=New signal("Création AG "+String($params.IDpersonne))
$durée:=Milliseconds
CALL WORKER("WK_ArbreGenealogie"; Formula from string("cs.$arbre.new($1).Créer_AG()"); $params)
// attendre le trigger du signal
This.trace.Error:=-16302*Num(Not($params.finDeTâche.wait(60))) // Patienter 1 mn maximum
If (This.trace.Error=0)
// c'est ok, renvoyer l'arbre
$params.arbreXML:=OB Get($params.finDeTâche; "arbre"; Is text)
Else
This.trace.ErrorDescription:="la function 'Créer_AG' du worker 'WK_ArbreGenealogie' n'a pas terminé en moins d'1 minute"
End if
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); $params.optionsMsg; "Fin traitement"; Current method name; "Durée du traitement :"+String(Milliseconds-$durée)+" ms"; New object("nomProcess"; Current process name; "numProcess"; Current process))
// nettoyer
OB REMOVE($params; "finDeTâche")
End if
This.trace.FixerSuccess()
This.trace.LeverException([msgk_event; msgk_log])
$params.success:=This.trace.success
Function Modifier_AG($paramsArbre : Object)
// le déploiement va se faire dans un Worker (préemptif) qui ne peut renvoyer le résultat qu'à un autre Worker
// le process de modification doit donc être un Worker
If (Count parameters=0)
$paramsArbre:=This.paramsArbre
End if
// point d'entrée unique des modifications (appel du Worker)
// v6.8.7 : les restrictions sur les données sont des collections dans This.paramsArbre. on les trimbale dans This.paramsArbre jusqu'au endUser
CALL WORKER("WK_ArbreGenealogie"; Formula from string("cs._modification_BDD_AG.new($1).Exécuter()"); $paramsArbre)
Function _ValiderParams($params : Object)->$result : cs._Trace
$result:=This.trace.Initialiser(Current method name)
Case of
: (Not(OB Is defined($params; "IDarbre")))
$result.Error:=-16317
$result.ErrorDescription:="l'ID de l'arbre,'IDarbre', n'est pas défini dans les paramètres de l'arbre"
: (Not(OB Is defined($params; "IDpersonne")))
$result.Error:=-16317
$result.ErrorDescription:="l'ID du De-Cujus,'IDpersonne', n'est pas défini dans les paramètres de l'arbre"
: (Not(OB Is defined($params; "Session_Etat")))
$result.Error:=-16317
$result.ErrorDescription:="l'état de la session, Session_Etat, n'est pas défini dans les paramètres de l'arbre"
: (Not(OB Is defined($params; "optionsMsg")))
$result.Error:=-16317
$result.ErrorDescription:="les options d'alertes utilisateur,'optionsMsg', ne sont pas définies dans les paramètres de l'arbre"
Else
// ok
// utile pour les réactiver en mode compilé
SET ASSERT ENABLED($params.Session_Etat ?? 8)
End case
$result.FixerSuccess()
$result.LeverException([msgk_event; msgk_log])
// ----------------------
//MARK:FORMevents FORM
// ----------------------
Function TraiterFORMevent()
var $nomOBJ : Text:="arbreSVG"
Case of
: (Not(OB Is defined(FORM Event; "objectName")))
: (Not(FORM Event.objectName=$nomOBJ))
: (Not(OB Is defined(This; "_FORM_"+$nomOBJ)))
Else
// event de l'objet formulaire $nomOBJ
// faire traiter l'event par la function du formulaire ou de l'objet
This["_FORM_"+$nomOBJ]()
End case
Function _FORM_arbreSVG()
var $ID_SVG; $uuid_objet_BDD : Text
Case of
// attention : arbreDOM existe a priori (a été créé avant !). arbreDOM n'appartient PAS au formulaire
// nécessaire en mode interprété
: (Undefined(arbreSVG))
: (Picture size(arbreSVG)=0)
// abandonner
: (FORM Event.code=On Mouse Move)
// visualiser un élément survolé et le mémoriser
// fixer les propriétés spécifiques au formulaire
If (This.Navigation=Null)
This.Navigation:=New object
This.Navigation.ZS:=New object
End if
// chercher l'élément survolé
$ID_SVG:=SVG Find element ID by coordinates(*; "arbreSVG"; MouseX; MouseY)
This.paramsArbre.EtatProcessus.ID_SVG:=$ID_SVG
// -- cas consultation
// remarque : ici l'état de la souris est fixé par la base hôte
This.Navigation.ZS.numTable:=0
This.Navigation.ZS.UUID_BDD:=""
Case of
: ((This.paramsArbre.EtatProcessus.Params ?? 0) | (This.paramsArbre.EtatProcessus.Params ?? 1))
: (This.paramsArbre.EtatProcessus.ID_SVG="")
// au cas ou...
This.DeSelectionnerElement()
: (Not($ID_SVG="@_2051"))
// filtrer les cadres
Else
$ID_SVG:=Split string($ID_SVG; "_")[0]
If (Match regex("[0-9]{8,8}"; $ID_SVG))
// le curseur est sur une zone sensible
This.Navigation.ZS.numTable:=CodeEnreg(Num($ID_SVG))
// récupérer le UUID de l'objet
SVG GET ATTRIBUTE(*; "arbreSVG"; $ID_SVG; "UUID"; $uuid_objet_BDD)
This.Navigation.ZS.UUID_BDD:=$uuid_objet_BDD
End if
End case
// passer la main à l'hôte
This.SubFormContainer.onSurVolElement()
// -- cas des éditions (modèle ou arbre)
// remarque : ici l'état de la souris est fixé par le composant
// dans l'ordre :
Case of
: (Not((This.paramsArbre.EtatProcessus.Params ?? 0) | (This.paramsArbre.EtatProcessus.Params ?? 1)))
// mode normal (hors edition)
: (This.paramsArbre.EtatProcessus.ID_SVG="@Ancres@")
// on survole une abncre, inviter au déplacement
SET CURSOR(9013)
: (This.paramsArbre.EtatProcessus.SelectedInformationID_SVG#"")
: (This.paramsArbre.EtatProcessus.SelectedElementID_SVG#"")
// un élément est sélectionné, on le garde (pour désélectionner : cliquer ailleurs)
Case of
: (This.paramsArbre.EtatProcessus.ID_SVG="@_CadreInformation")
// sélectionner l'information
This.SelectionnerInformation()
// rappel si une autre information était sélectionnée elle est désélectionnée
Else
This.DeSelectionnerInformation()
End case
: (This.paramsArbre.EtatProcessus.ID_SVG="@_CadreElement")
This.SelectionnerElement()
This.SubFormContainer.onSurVolElement()
: (This.paramsArbre.EtatProcessus.OverElementID_SVG#"")
// ici on est sorti de tout élément
This.DeSelectionnerElement()
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
// essayer un tip
//: (Editer Informations AG (Num($ID_SVG);->EtatProcessus))???
Else
// trappe
End case
: (FORM Event.code=On Clicked)
Case of
: (Macintosh option down)
//filtrer
: (Contextual click | Right click)
//filtrer
Else
$ID_SVG:=This.paramsArbre.EtatProcessus.ID_SVG
Case of
: ($ID_SVG="@Ancres@")
// déplacement d'une ancre
Case of
: ($ID_SVG="@Element@")
$ID_SVG:=This.paramsArbre.EtatProcessus.SelectedElementID_SVG
: ($ID_SVG="@Information@")
$ID_SVG:=This.paramsArbre.EtatProcessus.SelectedInformationID_SVG
End case
This.menu.DebuterDeplacementCadre($ID_SVG)
//Déplacer Element Arbre(Sur début déplacement ancre; ->$ID_SVG)
SET CURSOR(9014)
: ($ID_SVG="@_2051")
// navigation dans les entités
// rien de plus (action générique 'click dans une ZS')
Else
// clic ailleurs
This.DeSelectionnerElement()
//Select dans SVG_AG("DésélectionnerTout")
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
End case
End case
: (FORM Event.code=On Unload)
DOM CLOSE XML(arbreDOM)
End case
// ----------------------
// MARK:Entrées internes APP
// ----------------------
// ici : tous les points d'entrée interne de création d'un arbre généalogique
Function Créer_AG()
// on a appelé le WK : ré-initialiser le contexte, au besoin
This.InitProcess()
This.Effacer_AG()
// initialiser la structure de l'arbre
This.OuvrirBDD_Externe()
// lancer la modification de l'arbre
This.Modifier_AG()
// ----------------------
// MARK:Appels dessin
// ----------------------
Function Dessiner_AG_dansVariable($data : Object)
// créer la structure XML de l'arbre
var $structureXML; $function : Text
// on a appelé le WK : initialiser le contexte, au besoin
This.InitProcess()
This.OuvrirBDD_Externe()
$structureXML:=""
cs._dessin.new(This.paramsArbre).CréerArbreXML(->$structureXML)
This.trace.EnvoyerMessages([msgk_debug]; Current method name; "structureXMLclasse "+Timestamp; $structureXML; New object("nomProcess"; Current process name; "numProcess"; Current process))
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); This.paramsArbre.optionsMsg; "Dessin"; Current method name; "Dessin terminé, image SVG créée"; New object("nomProcess"; Current process name; "numProcess"; Current process))
// on en fait quoi ? : quel est le contexte?
// v11.0.12 la possibilité d'écrire le dessin dans une variable process du process appelant est supprimée
Case of
: (OB Is defined(This.paramsArbre; "numFenetreAppelante"))
// lancer l'affichage dans le formulaire appelant
$function:="cs.$arbre.new($1).Afficher_AG_dansFormulaire($2)"
CALL FORM(OB Get(This.paramsArbre; "numFenetreAppelante"; Is longint); Formula from string($function); OB Copy(This.paramsArbre); $structureXML)
: (OB Is defined(This.paramsArbre; "finDeTâche"))
// passer le résultat et notifier la fin de tâche
Use (This.paramsArbre.finDeTâche)
This.paramsArbre.finDeTâche.arbre:=$structureXML
End use
This.paramsArbre.finDeTâche.trigger()
Else
ASSERT(cs._Trace.new().DebugerMethode("Dessin"; Current method name; "On ne sait pas où dessiner l'arbre"))
End case
This.FermerBDD_Externe()
Function Afficher_AG_dansFormulaire($structureXML : Text)
// on est dans le process du formulaire appelant
var arbreDOM; arbreXML : Text
var arbreSVG : Picture
var ParamsArbre : Object
var $ID_SVG : Text
TEXT TO DOCUMENT(Folder(fk home folder).folder("tempo_ALV/_ARBdebug/"+Current method name).file(Timestamp+" $structureXML.svg").platformPath; $structureXML)
// init 'paramsArbre' pour le composant (ci-dessous et les IHM de SVG)
paramsArbre:=OB Copy(This.paramsArbre)
// afficher l'arbre
arbreDOM:=DOM Parse XML variable($structureXML)
// * restaurer le mode édition
This.menu.EditerElements(->arbreDOM)
// * restaurer la sélection du mode édition
$ID_SVG:=This.paramsArbre.EtatProcessus.SelectedElementID_SVG
Select dans SVG_AG("SélectionnerElement"; ->$ID_SVG)
// l'option "Copier source données XML" permet de stocker l'image et son réaffichage (doit être conservé, re-use pour l'IHM de l'image)
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
WRITE PICTURE FILE(Folder(fk home folder).folder("tempo_ALV/_ARBdebug/"+Current method name).file(Timestamp+" arbreSVG.svg").platformPath; arbreSVG)
// rmk : dans le formulaire 'AfficherArbre' fixer une grande taille à arbreSVG (supérieure à la plus grande taille d'écran !)
// sinon cela se passe mal dans les redimensionnements de formulaire
// indiquer la fin de traitement
Form.paramsArbre.tache.DésInscrire()
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); This.paramsArbre.optionsMsg; "Affichage"; Current method name; "Image SVG affichée"; New object("nomProcess"; Current process name; "numProcess"; Current process))
This.FermerBDD_Externe()
Function Effacer_AG()
arbreXML:=""
CLEAR VARIABLE(arbreSVG)
// ----------------------
// MARK:Styles
// ----------------------
Function LireStyleDuModele($racineXML : Text; $chemin : Text)->$result : Object
// retourner dans $result les couples /style/name - /style/value, au chemin $chemin de $racineXM
// attention : si pas de styles, $ptrStyles est un objet non défini et vide
var $xPath; $elementXML : Text
// * lire les styles du calque
DOM GET XML ELEMENT NAME($RacineXML; $xPath)
$xPath:="/"+$xPath+$chemin
$elementXML:=DOM Find XML element($RacineXML; $xPath)
$result:=This.LireStylesDuModeleElement($elementXML)
Function LireStylesDuModeleElement($racineXML : Text)->$result : Object
// retourner dans $result les couples /style/name - /style/value de $racineXML
// attention : si pas de styles, $result est un objet non défini et vide
var $xPath; $elementXML; $valeur : Text
var $i : Integer
$result:=New object
This.trace.Initialiser(Current method name)
// * lire les éléments styles
ARRAY TEXT($stylesList; 0)
$elementXML:=DOM Find XML element($racineXML; "stylesList/style"; $stylesList)
// * vérifier que des styles existent
If ((ok=1) & (Size of array($stylesList)>0))
For ($i; 1; Size of array($stylesList))
$elementXML:=DOM Find XML element($stylesList{$i}; "name")
If (ok=1)
DOM GET XML ELEMENT VALUE($elementXML; $xPath)
$elementXML:=DOM Find XML element($stylesList{$i}; "value")
If (ok=1)
DOM GET XML ELEMENT VALUE($elementXML; $valeur)
$result[$xPath]:=$valeur
Else
This.trace.Error:=-16305
This.trace.ErrorDescription:="Le style "+$xPath+" n'a pas de valeur"
break
End if
Else
This.trace.Error:=-16305
This.trace.ErrorDescription:="Le style "+$xPath+" "+String($i)+" n'a pas de nom"
break
End if
End for
Else
// il peut ne pas y avoir de style
This.trace.Error:=-16305
This.trace.ErrorDescription:="Information : absence de style"+$xPath+" (pas nécessaire)"
End if
This.trace.success:=($result.Error=0)
This.trace.LeverException([msgk_event; msgk_log])
Function LireStyleElement($IDarbre : Integer; $IDelement : Text; $propriété : Text; $ptrValeur : Pointer)->$result : Boolean
var $IDarbreSQL : Integer
var $styles : Object
var $dataTexte : Text
// rappel utile : les styles sont mémorisés dans le modèle. Pour le dessin ils sont recopiés dans style de la BDD_AG
SET BLOB SIZE($blob; 0)
This.OuvrirBDD_Externe()
$IDarbreSQL:=$IDarbre
Begin SQL
SELECT style FROM arbres WHERE id = :$IDarbreSQL INTO :$blob;
End SQL
BLOB TO VARIABLE($blob; $styles)
// lire la valeur de $propriété
Case of
: (OB Is empty($styles))
: ($styles[$IDelement]=Null)
: ($styles[$IDelement][$propriété]=Null)
Else
// renvoyer la valeur
$result:=True
$dataTexte:=$styles[$IDelement][$propriété]
Case of
: (Type($ptrValeur->)=Is text)
$ptrValeur->:=$dataTexte
: (Type($ptrValeur->)=Is longint)
$ptrValeur->:=Num($dataTexte)
// si une unité existe, elle est effacée
End case
End case
// ----------------------
// MARK:BDD_AG
// ----------------------
Function LireTableauxBDD_AG()->$tablesBDD_AG : Object
// Mémoriser les tableauxBDD_AG (champXXX) dans l'objet $tablesBDD_AG
// $1 permet alors de transmettre les tableaux à une méthode / un process / un worker
// v4.7 en mode préemptif (mais pas coopératif), les tableaux ne peuvent pas être passés en paramètre pointeur (RÉSOUDRE POINTEUR renvoie $VarName vide)
var $i; $j : Integer
var $ptr : Pointer
$tablesBDD_AG:=New object
// lister les nom de tableaux (process)
ARRAY TEXT($tableaux; 3)
$tableaux{1}:="champINT"
$tableaux{2}:="champREAL"
$tableaux{3}:="champBOOL"
For ($i; 1; Size of array($tableaux))
$ptr:=Get pointer($tableaux{$i})
// toujours un tableau 2D
If (Type($ptr->)=Array 2D)
For ($j; 1; Size of array($ptr->))
// le sous tableau peut être vide
If (Size of array($ptr->{$j})>0)
// mémoriser le tableau, la propriété contient le nom du tableau champ et son indice
OB SET ARRAY($tablesBDD_AG; "?"+$tableaux{$i}+"+?"+String($j); $ptr->{$j})
End if
End for
End if
// purger la mémoire
//EFFACER VARIABLE(${$i}->)
End for
Function EcrireTableauxBDD_AG($tablesBDD_AG : Object)
// Initialiser les tableauxBDD_AG à partir des tableaux de $1
var $Error; $i : Integer
var $c : Collection
var $VarName : Text
$Error:=0
Case of
// non vide
: (OB Is empty($tablesBDD_AG)=True)
$Error:=-15068
Else
// tout ok, on y va
// lister ce qu'on a reçu
ARRAY TEXT($propriétés; 0)
ARRAY LONGINT($types; 0)
OB GET PROPERTY NAMES($tablesBDD_AG; $propriétés; $types)
// pour plus de clareté du code, tabBDD_AG pointe sur tous ces tableaux "façon BDD"
ARRAY POINTER(BDD_AG; 23) //Taille tableau($propriétés))
For ($i; 1; Size of array($propriétés))
$c:=Split string($propriétés{$i}; "?"; sk ignore empty strings)
$c[0]:=Replace string($c[0]; "+"; "")
$Error:=-15068
Case of
// il faut recevoir un tableau
: ($types{$i}#Is collection) // v17 un tableau revoie 42
// le tableau reçu est renseigné
: ($c.length=0)
// remarque : tests suivants inutiles si $1 a été construit par "Fixer Données DéploiementArbre"
// il doit exister une variable déclarée de nom $Eléments{1}
: (Not(Is a variable(Get pointer($c[0]))))
// sa taille est suffisante
: (Num($c[1])>Size of array($propriétés))
Else
// ok, récupérer le tableau
$Error:=0
// ajouter le pointeur (avec les tests précédents, la variable existe !)
$VarName:=$c[0]+"{"+($c[1])+"}"
// on a un tableau valide
BDD_AG{Num($c[1])}:=Get pointer($VarName)
// lire le tableau
OB GET ARRAY($tablesBDD_AG; $propriétés{$i}; BDD_AG{Num($c[1])}->)
End case
End for
End case
// ----------------------
// MARK:IHS
// ----------------------
Function SelectionnerElement()
// sélectionner l'élément .ID_SVG
var $svgElement : Text
Case of
: (This.paramsArbre.EtatProcessus.OverElementID_SVG=Null)
: (This.paramsArbre.EtatProcessus.ID_SVG=Form.EtatProcessus.OverElementID_SVG)
Else
// on a changé d'élément
This.DeSelectionnerElement()
End case
$svgElement:=DOM Find XML element by ID(arbreDOM; This.paramsArbre.EtatProcessus.ID_SVG)
If (ok=1)
// sélectionner l'élément en cours
DOM SET XML ATTRIBUTE($svgElement; "stroke-opacity"; "1.0")
// renseigner le nouvel élément
This.paramsArbre.EtatProcessus.OverElementID_SVG:=This.paramsArbre.EtatProcessus.ID_SVG
This.paramsArbre.EtatProcessus.SelectedInformationID_SVG:=""
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
SET CURSOR(9000)
End if
Function SelectionnerInformation()
// sélectionner l'info .ID_SVG
var $svgElement : Text
Case of
: (This.paramsArbre.EtatProcessus.OverInformationID_SVG=Null)
: (This.paramsArbre.EtatProcessus.ID_SVG=This.paramsArbre.EtatProcessus.OverInformationID_SVG)
// déjà sélectionné
Else
// on a changé d'information
This.DeSelectionnerInformation()
End case
// sélectionner le nouveau
This.paramsArbre.EtatProcessus.OverInformationID_SVG:=This.paramsArbre.EtatProcessus.ID_SVG
$svgElement:=DOM Find XML element by ID(arbreDOM; This.paramsArbre.EtatProcessus.ID_SVG)
DOM SET XML ATTRIBUTE($svgElement; "stroke-opacity"; "1.0") // sélectionner l'information en cours
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
SET CURSOR(9000)
Function DeSelectionnerElement()
// désélectionner l'élément
var $ID_SVG : Text
Case of
: ((This.paramsArbre.EtatProcessus.OverElementID_SVG=Null) & (This.paramsArbre.EtatProcessus.SelectedElementID_SVG=Null))
$ID_SVG:=""
: (This.paramsArbre.EtatProcessus.OverElementID_SVG#"")
$ID_SVG:=This.paramsArbre.EtatProcessus.OverElementID_SVG
: (This.paramsArbre.EtatProcessus.SelectedElementID_SVG#"")
$ID_SVG:=This.paramsArbre.EtatProcessus.SelectedElementID_SVG
End case
This.DeSelectionner($ID_SVG; Num(Opacité Contour Cadre); Num(Opacité Remplissage CadreElement))
This.DeSelectionnerInformations()
// RAZ
This.paramsArbre.EtatProcessus.OverElementID_SVG:=""
This.paramsArbre.EtatProcessus.SelectedElementID_SVG:=""
This.paramsArbre.EtatProcessus.OverInformationID_SVG:=""
This.paramsArbre.EtatProcessus.SelectedInformationID_SVG:=""
SET CURSOR
Function DeSelectionnerInformations()
// désélectionner toutes les informations de l'élément selected
var $svgElement : Text
var $i : Integer
Case of
: (Not(OB Is defined(This.paramsArbre; "EtatProcessus")))
: (Not(OB Is defined(This.paramsArbre.EtatProcessus; "SelectedElementID_SVG")))
: (This.paramsArbre.EtatProcessus.SelectedElementID_SVG="")
Else
// lister de toutes les infos actuelles de l'élement
$svgElement:=DOM Find XML element by ID(arbreDOM; This.paramsArbre.EtatProcessus.SelectedElementID_SVG)
// ses informations
ARRAY TEXT($ElementXMLlist; 0)
$svgElement:=DOM Get parent XML element($svgElement)
$svgElement:=DOM Find XML element($svgElement; "g/rect[contains(@id,'_CadreInformation')]"; $ElementXMLlist)
For ($i; 1; Size of array($ElementXMLlist))
// masquer le rect de l'information
DOM SET XML ATTRIBUTE($ElementXMLlist{$i}; "visibility"; "hidden"; "stroke-opacity"; "0.3")
End for
End case
Function DeSelectionnerInformation()
// désélectionner l'élément
var $ID_SVG : Text
Case of
: ((This.paramsArbre.EtatProcessus.OverInformationID_SVG=Null) & (This.paramsArbre.EtatProcessus.SelectedInformationID_SVG=Null))
$ID_SVG:=""
: (This.paramsArbre.EtatProcessus.OverInformationID_SVG#"")
$ID_SVG:=This.paramsArbre.EtatProcessus.OverInformationID_SVG
: (This.paramsArbre.EtatProcessus.SelectedInformationID_SVG#"")
$ID_SVG:=This.paramsArbre.EtatProcessus.SelectedInformationID_SVG
End case
This.DeSelectionner($ID_SVG; Num(Opacité Contour Cadre); Num(Opacité Remplissage CadreInformation))
Function DeSelectionner($ID_SVG : Text; $strokeOpacity : Real; $fillOpacity : Real)
var $svgElement : Text
If ($ID_SVG#"")
// désélectionner, restaurer les attributs
$svgElement:=DOM Find XML element by ID(arbreDOM; $ID_SVG)
DOM SET XML ATTRIBUTE($svgElement; "stroke-opacity"; String($strokeOpacity; "&xml"); "fill-opacity"; String($fillOpacity; "&xml"))
// masquer les ancres
$ID_SVG:=$ID_SVG+"Ancres"
$svgElement:=DOM Find XML element by ID(arbreDOM; $ID_SVG)
If (ok=1)
DOM SET XML ATTRIBUTE($svgElement; "visibility"; "hidden") // au cas où
End if
End if
⇧
[class]Pays - 29/05/2025 12:43:16
property nom : Text
Class extends _ARB_DataStore
Class constructor($IDentité : Variant)
// initialiser l'objet avec les données de l'entité $IDentité de la BDD
Super("Pays"; $IDentité)
Function Libellé($formats : Object)->$libellé : Text
// renvoie le nom formaté suivant les options $1
// .Options
// aucune
$libellé:=This.nom
⇧
[class]Lieux - 29/05/2025 13:05:19
// utilisés par les appelants
property ID : Integer
Class extends _ARB_DataStore
Class constructor($IDentité : Variant)
// initialiser l'objet avec les données de l'entité $IDentité de la BDD
Super("Lieux"; $IDentité)
⇧
[class]_modification_AG - 18/02/2026 09:44:45
// traiter les commandes utilisateur
// elles sont déclénchées par le Client APP : on appelle la base hôte pour exécuer la commande sur le serveur APP
property SubFormContainer : Object:=Null
property svgElement : Text
property IDcadre : Integer
Class extends _modification_modele_AG
Class constructor($host : Object)
Super()
This.trace:=cs._Trace.me
This.SubFormContainer:=$host
// ----------------------
// MARK:Commandes menu
// ----------------------
Function ChangerModele($propriété : Text; $valeur : Text)
// changer de modèle (on aurait pu ici ouvrir le sélecteur de fichiers)
This.paramsArbre.Modele:=$valeur
This.paramsArbre.functionID:=cagk Appliquer Modèle
This.SubFormContainer.onModification()
Function FixerNombreAscendance()
This.FixerNombreXscendance(121; "NmaxAscendance")
Function FixerNombreDescendance()
This.FixerNombreXscendance(122; "NmaxDescendance")
Function ModifierModele()
// autoriser la modification du modèle de l'arbre
// fixer le bit 0 de .EtatProcessus.Params
If (This.paramsArbre.EtatProcessus.Params ?? 0)
// fin édition du modèle
This.paramsArbre.EtatProcessus.Params:=This.paramsArbre.EtatProcessus.Params ?- 0
This.ModificationModele:=""
This.functionID:=cagk Dessiner dans variable
CALL SUBFORM CONTAINER(ALV sur Modification)
Else
// passer en mode édition modèle
This.paramsArbre.EtatProcessus.Params:=This.paramsArbre.EtatProcessus.Params ?+ 0
This.ModificationModele:="ModificationModele"
This.paramsArbre.EtatProcessus.Params:=This.paramsArbre.EtatProcessus.Params ?- 1
This.ModificationArbre:=""
This.paramsArbre:=Form.paramsArbre
This.EditerElements(->arbreDOM)
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
End if
Function ModifierArbre()
// autoriser la modification de l'arbre
// fixer le bit 1 de .EtatProcessus.Params
If (This.paramsArbre.EtatProcessus.Params ?? 1)
This.paramsArbre.EtatProcessus.Params:=This.paramsArbre.EtatProcessus.Params ?- 1
This.ModificationArbre:=""
Else
This.paramsArbre.EtatProcessus.Params:=This.paramsArbre.EtatProcessus.Params ?+ 1
This.ModificationArbre:="ModificationArbre"
This.paramsArbre.EtatProcessus.Params:=This.paramsArbre.EtatProcessus.Params ?- 0
This.ModificationModele:=""
End if
Function ArchiverArbre()
// rien dans cette version !
BEEP
Function EditerRedimensionnementCadre()
// afficher les ancres de redimensionnement
This.svgElement:=Form.paramsArbre.EtatProcessus.OverElementID_SVG
This.SelectionnerAncres()
Function EditerDeplacementConnexion()
ALERT(Current method name+" : commande non traitée")
Function EditerModificationsInformations()
// afficher le rect des informations
This.EditerInformations()
// ----------------------
// MARK:Params AG
// ----------------------
Function FixerNombreXscendance($libellé : Integer; $attribut : Text)
If (Storage.System.EstExecuteDansHote)
// changer Nmax ascendants
This.OuvrirFormulaireSaisie($libellé)
If (Form.texteSaisi#"")
Form[$attribut]:=Num(Form.texteSaisi)
Form.functionID:=cagk Construire
CALL SUBFORM CONTAINER(ALV sur Modification)
End if
End if
Function EditerElements($ptrArbreXML : Pointer)
// ici on dessine l'arbre
// ajouter les xxxElement à la structure XML $1 en fonction des options courantes
var $IDarbre; $i : Integer
// variables pour les requêtes SQL
$IDarbre:=This.paramsArbre.IDarbre
// chercher tous les calques
ARRAY LONGINT($tabID; 0)
Case of
: (Not(OB Is defined(This.paramsArbre.EtatProcessus; "Params")))
: (This.paramsArbre.EtatProcessus.Params ?? 0)
// sélectionner tous les cadres de l'arbre
ALERT(Current method name+" 2026-02-06 NON ne peut pas fonctionner sur le client")
//This.OuvrirBDD_Externe()
//Begin SQL
//SELECT id FROM cadres WHERE arbre = :$IDarbre INTO :$tabID;
//End SQL
//This.FermerBDD_Externe()
: (This.paramsArbre.EtatProcessus.Params ?? 0) //oops!
// sélectionner le cadre en modification
// a faire
End case
If (Size of array($tabID)>0)
// en SVG, le dernier dessiné est au dessus => l'ajout doit se faire par couche
// * dessiner les cadreElements
This.paramsArbre.EtatProcessus.Params:=This.paramsArbre.EtatProcessus.Params & 0xFFFFFFE3 // raz options
This.paramsArbre.EtatProcessus.Params:=(This.paramsArbre.EtatProcessus.Params ?+ 3) ?+ 4 // dessiner les cadreElements et les ancreElements
For ($i; 1; Size of array($tabID))
This.IDcadre:=$tabID{$i}
This.AjouterLeModeleCadre($ptrArbreXML)
End for
End if
Function EditerInformations()
// afficher le rect des informations de l'élément sélectionné
var $svgElement : Text
var $i : Integer
If (Form.paramsArbre.EtatProcessus.SelectedElementID_SVG#"")
$svgElement:=DOM Find XML element by ID(arbreDOM; Form.paramsArbre.EtatProcessus.SelectedElementID_SVG)
// on fixe l'opacity à 0 pour que le survol 'voit' les '_CadreInformation'
DOM SET XML ATTRIBUTE($svgElement; "fill-opacity"; "0.0")
// lister de toutes les infos actuelles de l'élement
ARRAY TEXT($ElementXMLlist; 0)
$svgElement:=DOM Get parent XML element($svgElement)
$svgElement:=DOM Find XML element($svgElement; "g/rect[contains(@id,'_CadreInformation')]"; $ElementXMLlist)
For ($i; 1; Size of array($ElementXMLlist))
DOM SET XML ATTRIBUTE($ElementXMLlist{$i}; "visibility"; "visible") // afficher le rect de l'information
End for
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
End if
// ----------------------
// MARK:Dessin IHM modifications
// ----------------------
Function AjouterLeModeleCadre($ptrArbreXML : Pointer)
// ici on dessine l'arbre
// si les options 3 et 4 des params du l'EtatProcessus sont demandées, on trace les cadres de modifications des cadres
var $IDcadre; $IDobjetBDD : Integer
var $largeur; $hauteur : Real
var $deployed : Boolean
var $Xpath; $arbreXML; $ElementXML; $EnfantXML : Text
var $blob : Blob
// structure de l'arbre modifiée localement
$arbreXML:=$ptrArbreXML->
// variables pour les requêtes SQL
$IDcadre:=This.IDcadre
Begin SQL
SELECT id_objet_BDD, largeur, hauteur, data, deployed FROM cadres WHERE id = :$IDcadre INTO :$IDobjetBDD, :$largeur, :$hauteur, :$blob, :$deployed;
End SQL
If ($deployed)
// le cadre est déployé (définitivement positionné dans l'arbre)
// lire la structure
DOM GET XML ELEMENT NAME($arbreXML; $Xpath) // récupérer la racine
$Xpath:="/"+$Xpath
If (ok=1)
// trouver le groupe d'informations du cadre
$ElementXML:=DOM Find XML element by ID($arbreXML; String($IDobjetBDD))
// * si demandés, ajouter les artefacts d'IHM
If (This.paramsArbre.EtatProcessus.Params ?? 3)
// * créer le rect du cadre. Entourer le cadre
$EnfantXML:=DOM Create XML element($ElementXML; "rect"; "class"; "CadreElement"; "id"; String($IDobjetBDD)+"_CadreElement"; "x"; -Décalage CadreElement; "y"; -Décalage CadreElement; "width"; $largeur+(2*Décalage CadreElement); "height"; $hauteur+(2*Décalage CadreElement); "visibility"; "visible"; "stroke-opacity"; String(Opacité Contour Cadre; "&xml"); "fill-opacity"; String(Num(Opacité Remplissage CadreElement); "&xml"))
End if
If (This.paramsArbre.EtatProcessus.Params ?? 4)
// * créer l'ancre de redimensionnement du cadre
$EnfantXML:=DOM Create XML element($ElementXML; "g"; "id"; String($IDobjetBDD)+"_CadreElementAncres"; "visibility"; "hidden"; "transform"; "translate("+String($largeur; "&xml")+","+String($hauteur; "&xml")+")")
$EnfantXML:=DOM Create XML element($EnfantXML; "rect"; "class"; "AncreCadre"; "id"; String($IDobjetBDD)+"_CadreElementAncresRedim"; "x"; Décalage CadreElement; "y"; Décalage CadreElement; "width"; Taille ancre; "height"; Taille ancre)
End if
End if
// ajouter le cadre des informations du cadre
This.AjouterLeModeleInformation($ptrArbreXML; $IDobjetBDD; $blob; $largeur; $hauteur)
End if
// renvoyer la nouvelle structure
$ptrArbreXML->:=$arbreXML
Function AjouterLeModeleInformation($ptrArbreXML : Pointer; $IDobjetBDD : Integer; $Blob : Blob; $largeur : Real; $hauteur : Real)
// ici on dessine l'arbre
// si les options 3 et 4 des params du l'EtatProcessus sont demandées, on trace les cadres de modifications des informations des cadres
var $arbreXML; $ElementXML; $EnfantXML; $PetitEnfantXML; $nameID : Text
var $data; $information : Object
var $typeInfo : Integer
BLOB TO VARIABLE($blob; $data)
// structure de l'arbre modifiée localement
$arbreXML:=$ptrArbreXML->
Case of
: (Not(OB Is defined($data; "informations")))
: ($data.informations.length=0)
Else
// ok on y va
For each ($information; $data.informations)
$typeInfo:=$information.typeInfo
$nameID:=String($IDobjetBDD)+"_"+String($typeInfo)
$ElementXML:=DOM Find XML element by ID($arbreXML; $nameID)
// placer les éléments à la fin du groupe (après le _cadreElement
//$ElementXML:=DOM Get parent XML element($ElementXML)
If (ok=1)
If (This.estEditable($typeInfo))
// créer le rect du rect
$hauteur:=16
$EnfantXML:=DOM Create XML element($ElementXML; "rect"; "class"; "CadreInformation"; "id"; $nameID+"_CadreInformation"; "x"; 0; "y"; 0; "width"; $largeur; "height"; $hauteur; "visibility"; "hidden"; "stroke-opacity"; String(Opacité Contour Cadre; "&xml"))
End if
If (This.estRedimensionnable($typeInfo))
// * créer les ancres de repositionnnement de l'info
$EnfantXML:=DOM Create XML element($ElementXML; "g"; "id"; $nameID+"_CadreInformationAncres"; "visibility"; "hidden"; "transform"; "translate(0,0)")
$PetitEnfantXML:=DOM Create XML element($EnfantXML; "rect"; "class"; "AncreCadre"; "id"; $nameID+"_CadreInformationAncresReposGH"; "x"; -Taille ancre; "y"; -Taille ancre; "width"; Taille ancre; "height"; Taille ancre)
$PetitEnfantXML:=DOM Create XML element($EnfantXML; "rect"; "class"; "AncreCadre"; "id"; $nameID+"_CadreInformationAncresReposDH"; "x"; $largeur; "y"; -Taille ancre; "width"; Taille ancre; "height"; Taille ancre)
$PetitEnfantXML:=DOM Create XML element($EnfantXML; "rect"; "class"; "AncreCadre"; "id"; $nameID+"_CadreInformationAncresReposGB"; "x"; -Taille ancre; "y"; $hauteur; "width"; Taille ancre; "height"; Taille ancre)
$PetitEnfantXML:=DOM Create XML element($EnfantXML; "rect"; "class"; "AncreCadre"; "id"; $nameID+"_CadreInformationAncresReposDB"; "x"; $largeur; "y"; $hauteur; "width"; Taille ancre; "height"; Taille ancre)
End if
End if
End for each
End case
// renvoyer la nouvelle structure
$ptrArbreXML->:=$arbreXML
Function estEditable($typeInfo : Integer)->$result : Boolean
// définir si cette information est éditable
// (les tracés, éléments type 205x, ne sont pas éditables)
$result:=True
Case of
: (Not(This.paramsArbre.EtatProcessus.Params ?? 3))
// pas demandé
: ($typeInfo=2051)
: ($typeInfo=2052)
: ($typeInfo=2053)
: ((($typeInfo>2040) & ($typeInfo<2050)) | (($typeInfo>=20000) & ($typeInfo<=39999)))
Else
$result:=False
End case
Function estRedimensionnable($typeInfo : Integer)->$result : Boolean
// définir si le cadre de cette information est redimensionnable
$result:=True
Case of
: (Not(This.paramsArbre.EtatProcessus.Params ?? 4))
// pas demandé
: ((($typeInfo>2040) & ($typeInfo<2050)) | (($typeInfo>=20000) & ($typeInfo<=39999)))
Else
$result:=False
End case
// ----------------------
// MARK:Redimensionnement
// ----------------------
Function SelectionnerAncres()
// afficher les ancres de l'élément sélectionné
var $ID_SVG; $svgElement : Text
$ID_SVG:=This.svgElement+"Ancres"
$svgElement:=DOM Find XML element by ID(arbreDOM; $ID_SVG)
If (ok=1)
DOM SET XML ATTRIBUTE($svgElement; "visibility"; "visible")
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
End if
Function DebuterDeplacementCadre($ID_SVG : Text)
// mémoriser le cadreElement ou CadreInformation concerné
var PositionX; PositionY : Integer
This.paramsArbre.EtatProcessus.MovedID:=$ID_SVG
// mémoriser le départ du déplacement
This.paramsArbre.EtatProcessus.PositionX:=MouseX
This.paramsArbre.EtatProcessus.PositionY:=MouseY
PositionX:=MouseX
PositionY:=MouseY
SET TIMER(10)
Function Déplacer()
var $déplacementX; $déplacementY; $boutonSouris : Integer
var $svgElement; $ID_SVG; $attribut; $functionID : Text
Case of
: (Not(OB Is defined(This.paramsArbre.EtatProcessus; "MovedID")))
: (This.paramsArbre.EtatProcessus.MovedID="")
Else
// déplacement en cours
$ID_SVG:=This.paramsArbre.EtatProcessus.MovedID
// lire le déplacement entre 2 appels
$déplacementX:=MouseX-PositionX
$déplacementY:=MouseY-PositionY
$functionID:="Deplacer"+Split string($ID_SVG; "_")[1]
If (OB Is defined(This; $functionID))
This[$functionID]($déplacementX; $déplacementY)
End if
Case of
: ($ID_SVG="@CadreElement@")
// agrandir le cadre
//DOM GET XML ATTRIBUTE BY NAME($svgElement; "width"; $largeur)
//DOM GET XML ATTRIBUTE BY NAME($svgElement; "height"; $hauteur)
//DOM SET XML ATTRIBUTE($svgElement; "width"; $largeur+$déplacementX; "height"; $hauteur+$déplacementY)
// rmk "transform" contient maintenant les nouvelles dimensions du cadre
BEEP
: ($ID_SVG="@CadreInformation@")
// repositionner le cadre
$svgElement:=DOM Get parent XML element($svgElement) // l'ancre $ID_SVG est dans un groupe
DOM GET XML ATTRIBUTE BY NAME($svgElement; "transform"; $attribut)
// ajouter le déplacement à l'attribut translate
Déplacer Element Arbre("EcrireParamsTranslate"; ->$attribut; ->$déplacementX; ->$déplacementY)
DOM SET XML ATTRIBUTE($svgElement; "transform"; $attribut)
// rmk "transform" contient maintenant la nouvelle position de l'information
End case
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
// repartir de la position courante
PositionX:=MouseX
PositionY:=MouseY
MOUSE POSITION($déplacementX; $déplacementY; $boutonSouris)
If ($boutonSouris=0)
This.TerminerDeplacement()
End if
End case
Function DeplacerCadreElement($déplacementX : Integer; $déplacementY : Integer)
var $svgElement : Text
var $largeur; $hauteur : Integer
$svgElement:=DOM Find XML element by ID(arbreDOM; This.paramsArbre.EtatProcessus.MovedID)
If (ok=1)
// agrandir le cadre
DOM GET XML ATTRIBUTE BY NAME($svgElement; "width"; $largeur)
DOM GET XML ATTRIBUTE BY NAME($svgElement; "height"; $hauteur)
$largeur:=$largeur+$déplacementX
$hauteur:=$hauteur+$déplacementY
DOM SET XML ATTRIBUTE($svgElement; "width"; $largeur; "height"; $hauteur)
This.FixerPositionAncre($largeur; $hauteur)
SVG EXPORT TO PICTURE(arbreDOM; arbreSVG; Copy XML data source)
End if
Function DeplacerCadreInformation()
Function FixerPositionAncre($largeur : Integer; $hauteur : Integer)
// repositionner les ancres ; $largeur/ $hauteur sont les dimensions du cadreElement
var $svgElement; $attribut : Text
TEXT TO DOCUMENT(Folder(fk home folder).folder("tempo_ALV/_ARBdebug").file(Timestamp+".txt").platformPath; String($largeur)+". "+String($hauteur)+". "+String($largeur-(2*Décalage CadreElement))+". "+String($hauteur-(2*Décalage CadreElement)))
$svgElement:=DOM Find XML element by ID(arbreDOM; This.paramsArbre.EtatProcessus.MovedID+"Ancres")
If (ok=1)
// recréer l'attribut translate avec les params
$attribut:=This.FixerDimensionsTranslate($largeur-(2*Décalage CadreElement); $hauteur-(2*Décalage CadreElement))+")"
DOM SET XML ATTRIBUTE($svgElement; "transform"; $attribut)
End if
Function TerminerDeplacement()
var $ID_SVG; $svgElement; $attribut : Text
var $largeur; $hauteur : Integer
// lire le redimensionnement / déplacement dans l'attribut "transform"
$ID_SVG:=This.paramsArbre.EtatProcessus.MovedID
// arrêter l'espionnage
SET TIMER(0)
This.paramsArbre.EtatProcessus.MovedID:=""
$svgElement:=DOM Find XML element by ID(arbreDOM; $ID_SVG+"Ancres")
DOM GET XML ATTRIBUTE BY NAME($svgElement; "transform"; $attribut)
$largeur:=0
$hauteur:=0
This.LireDimensionsTranslate($attribut; ->$largeur; ->$hauteur)
TEXT TO DOCUMENT(Folder(fk home folder).folder("tempo_ALV/_ARBdebug").file(Timestamp+"_fin.txt").platformPath; String($largeur)+". "+String($hauteur))
// appliquer les nouvelles dimensions au modèle
This.OuvrirBDD_Externe()
This.Redimensionner($ID_SVG; $largeur; $hauteur)
Case of
: ($ID_SVG="@CadreElement@")
//Modifier Arbre(204; ->$largeur; ->$hauteur)
: ($ID_SVG="@CadreInformation@")
Modifier Arbre(303; ->$largeur; ->$hauteur)
End case
This.AfficherArbre()
Function FixerDimensionsTranslate($largeur : Integer; $hauteur : Integer)->$result : Text
// créer l'attribut 'translate'
$result:="translate("+String($largeur)+","+String($hauteur)
Function LireDimensionsTranslate($attribut : Text; $ptrDéplacementX : Pointer; $ptrDéplacementY : Pointer)
// renvoyer dans $ptrDéplacementX et $ptrDéplacementX les arguments "translate" de $attribut
var $texte : Text
var $c : Collection
// $attribut est de la forme 'translate(X,Y)'
// virer "translate"
$texte:=Replace string($attribut; "translate"; "")
$texte:=Substring($texte; 2; Length($texte)-2)
// récupérer X et Y
$c:=Split string($texte; ",")
$ptrDéplacementX->:=Num($c[0])
$ptrDéplacementY->:=Num($c[1])
// ----------------------
// MARK:Utilitaires
// ----------------------
Function AfficherArbre()
//un élément de la BDD_AG a été modifié ; ré-afficher l'arbre
// appliquer le modèle modifié et déployer
Form.functionID:=cagk Appliquer Modèle
CALL SUBFORM CONTAINER(ALV sur Modification)
Function AfficherViewer()
SVGTool_Display_viewer
SVGTool_SHOW_IN_VIEWER(arbreDOM)
DOM EXPORT TO FILE(arbreDOM; Folder(fk documents folder).folder("tempo_ALV").folder("_ARBdebug").file("testStructureSVG.xml").platformPath)
⇧
[class]PersonnesSelect - 29/05/2025 12:50:19
property selectionRecherche : Collection
Class extends _ARB_DataStore
Class constructor($requête : Variant)
Super("PersonnesSelect"; $requête)
This.selection:=Null
This.length:=0
// ----------------------
//MARK:Selection
// -----------------------
Function TrierSelectionRecherche()
// trier par nom / prenom
This.selectionRecherche:=This.selectionRecherche.orderBy("itemNom asc")
Function trierParDate($formats : Object)
// trier la sélection de personnes par la date de naissance
var $sensDuTri : Integer
$sensDuTri:=dk ascending
// $sensDuTri:=dk descending // pour test !
Case of
: (Count parameters=0)
: (OB Is defined($1; "sensDuTri"))
$sensDuTri:=$1.sensDuTri
End case
TRACE
//$result:=This.selection.orderBy("This.lesEvents.Naissance().dateNum"; $sensDuTri)
⇧
[class]Departements - 13/01/2025 12:50:24
Class extends _ARB_DataStore
Class constructor($IDentité : Variant)
// initialiser l'objet avec les données de l'entité $IDentité de la BDD
Super("Departements"; $IDentité)
⇧
[class]Medias - 18/11/2022 12:22:41
Class extends localDataStore
Class constructor()
// initialiser un objet vide
Super("Medias"; 19)
⇧
[class]Unions - 29/05/2025 12:41:59
property ID : Integer
property leEvent : cs.Events
property lesMembres : Object
// utilisés par les appelants
property IDunique : Text
Class extends _ARB_DataStore
Class constructor($IDentité : Variant)
// initialiser l'objet avec les données de l'entité $IDunique de la BDD
var $c : Collection
Super("Unions"; $IDentité)
// pour trier les unions, mettre l'event ici
// attention il peut ne pas y en avoir
This.leEvent:=Null
$c:=This.fct.LesEvents()
// prendre le premier
If ($c.length>0)
This.leEvent:=cs.Events.new($c[0])
End if
Function Libellé($formats : Object)->$result : Text
// renvoie le nom formaté des protagonistes suivant les options $formats
// $formats
// l'union (parentale par exemple) peut être nulle
var $sélection : cs.PersonnesSelect
var $entité : cs.Personnes
var $lien : Text
If (This.ID#0)
// sélectionner les membres de l'union
$sélection:=This.LesProtagonistes()
// coder leur noms
$result:=""
$lien:=" & "
For each ($entité; $sélection.selection)
$result:=$result+$lien+$entité.Libellé($formats)
End for each
// nettoyer
$result:=Replace string($result; $lien; ""; 1)
End if
// ----------------------
//MARK:Selection
// ----------------------
Function LesProtagonistes()->$result : cs.PersonnesSelect
// créer la sélection de personnes
var $c : Collection
$result:=cs.PersonnesSelect.new(This.fct.LesProtagonistes())
// ordonner les protagonistes : membre1 = homme, membre2 = femme
$result.Créer()
$c:=$result.selection // le personnes
This.lesMembres:=New object
// rappel : homme sexe = faux, femme sexe = vrai
// plusieurs cas
Case of
: ($c.length=0)
This.lesMembres:=Null
: ($c.length=1)
This.lesMembres.membre1:=Null
This.lesMembres.membre2:=Null
If ($c[0].sexe)
This.lesMembres.membre2:=$c[0]
Else
This.lesMembres.membre1:=$c[0]
End if
Else
$c:=$c.orderBy("sexe asc")
This.lesMembres.membre1:=$c[0]
This.lesMembres.membre2:=$c[1]
End case
Function LesEnfants()->$result : cs.PersonnesSelect
// envoie la sélection d'entités [Personnes] enfants de l'union, triée par date de naissance
// peut ne pas exister
var $c : Collection
var $entité : Object
$result:=Null
$c:=This.fct.LesEnfants()
If ($c.length>0)
$result:=cs.PersonnesSelect.new($c)
$result.Créer()
// ajouter la date de naissance
For each ($entité; $result.selection)
$entité.date:=$entité.Naissance().dateNum
End for each
// trier
$result.selection:=$result.selection.orderBy("date asc")
End if
// ----------------------
//MARK:Selection
// ----------------------
Function getMembres()->$result : Object
$result:=This.lesMembres
Function getLeConjoint($ID : Integer)->$result : Object
// trouver les membres de l'union
This.LesProtagonistes()
// chercher dans les membres celui dont l'ID n'est pas $ID
If (This.lesMembres.membre1.ID=$ID)
$result:=This.lesMembres.membre2
Else
$result:=This.lesMembres.membre1
End if
⇧
[class]BioData - 02/08/2026 11:29:11
property entities : Collection
property paramsArbre : Object
shared singleton Class constructor()
This.entities:=New shared collection
This.paramsArbre:=New shared object
Function RAZ()
Use (This.entities)
This.entities:=New shared collection
End use
shared Function Ajouter($entité : Object)
// ajouter $entité à entities
var $c : Collection
var $entitéPartagée : Object
Case of
: (Not(OB Is defined($entité; "DataClassNom")))
: (Not(OB Is defined($entité; "ID")))
Else
$c:=This.entities.query("DataClassNom = :1 and ID = :2"; $entité.DataClassNom; $entité.ID)
If ($c.length=0)
$entitéPartagée:=OB Copy($entité; ck shared; This.entities)
This.entities.push($entitéPartagée)
End if
End case
Function Chercher($IDobjetBDD : Integer; $typeInfo : Integer; $ptrEntité : Pointer)->$result : Integer
// sélectionne dans la BDD l'entité liée au type d'info $2 de IDobjetBDD $1, retour dans objet $3
// gére l'absence de BDD
// erreur renvoyée :
// -15068 : pb de paramètre de la méthode
// -16312 : type d'info non géré ici
// -16318 : entité non connue de la BDD
// -16330 : entité non webable
var $entité : Object
var $c : Collection
$result:=0
$entité:=Null
If (Storage.System.EstExecuteDansHote)
// utiliser la collection d'entities
// lire l'entité demandée
$entité:=Null
$c:=This.entities.query("numTable = :1 and ID = :2"; $IDobjetBDD >> 24; $IDobjetBDD & 0x00FFFFFF)
If ($c.length=1)
$entité:=$c[0]
End if
Case of
: (CodeEnreg($IDobjetBDD)=204)
// information inconnue (ce cas peut exister)
: ($entité=Null)
// peut être normal (les créations des arbres s'enchainent sans aboutir)
$result:=0
ASSERT(cs._Trace.new().DebugerMethode("BDD"; Current method name; "L'entité ID "+String($IDobjetBDD & 0x00FFFFFF)+" de la table num "+String($IDobjetBDD >> 24)+"n'est pas dans la BioData"))
// l'information peut être non affichable
: ($entité.DataClassNom="Personnes")
$result:=This.existePersonne($entité)
: ($entité.DataClassNom="Events")
$result:=0
Case of
// il y a des restrictions
: (This.paramsArbre.EventsAffichables=Null)
// on a les données webables
: (This.paramsArbre.EntitésWebables=Null)
// on a les evennements webables
: (This.paramsArbre.EntitésWebables[This.paramsArbre.EventsAffichables]=Null)
// l'enregistrement est affichable
: (This.paramsArbre.EntitésWebables[This.paramsArbre.EventsAffichables].indexOf($entité.ID)>-1)
// c'est ok
Else
// données masquées
$result:=-16330
End case
: ($entité.DataClassNom="Unions")
// pas de restriction
$result:=0
Else
// cas non traité
$result:=-16318
End case
// lire les données de l'information
Case of
: ($entité=Null)
// pas d'entité
: ($result#0)
// données masquées
: (($typeInfo=2041) | ($typeInfo=2042))
// rien à faire de plus
// une entité de [Personnes] est sélectionnée
: ($typeInfo=2043)
// image non gérée dans cette version
$entité:=New object
ASSERT(False; "le dessin d'une image n'est pas gérée")
: (($typeInfo=22000) | ($typeInfo=22100)) // naissance ou décès
// une entité de [Personnes] est sélectionné
// chercher l'event perso de la personne demandé
$entité:=$entité.getEventPersonnel($typeInfo)
$result:=This.existeEvent($entité)
: ($typeInfo=33600)
// un enregistrement de [Unions] est sélectionné
// chercher le event fam de l'union courante
$entité:=$entité.leEvent
$result:=-16318*Num($entité=Null)
Else
//type info non reconnue
$result:=-16312
End case
Else
// *** utiliser des données factices
// créer les données de l'information
Case of
: (($typeInfo=2041) | ($typeInfo=2042))
$entité:=cs.Personnes.new()
$entité.fct.nom:="Dupond de Lagrange"
$entité.fct.prenom:="Gonzague"
$entité.fct.autres_prenoms:="Louis Alphonse"
: ($typeInfo=2043)
$entité:=cs.Personnes.new()
$entité.comment:="Data du composant SQL"
: ($typeInfo=22000) // naissance
$entité:=cs.Events.new()
$entité.fct.typeEvent:=22000
$entité.fct.dateValid:=True
$entité.fct.dateNum:=Add to date(Current date; -10; 0; -10)
$entité.fct.dateChaine:="vers 1789"
$entité.fct.leLieu.leSite.laCommune.nom:="Trifouilly-lès-Oies"
$entité.fct.leLieu.leSite.laCommune.leDepartement.numero:=971
: ($typeInfo=22100) // décès
$entité:=cs.Events.new()
$entité.typeEvent:=22100
$entité.dateValid:=False
$entité.dateNum:=Current date
$entité.dateChaine:="vers 2089"
$entité.leLieu.leSite.laCommune.nom:="Pétaouchnoc"
$entité.leLieu.leSite.laCommune.leDepartement.numero:=972
: ($typeInfo=33600) // mariage
$entité:=cs.Events.new()
$entité.fct.typeEvent:=33600
$entité.fct.dateValid:=True
$entité.fct.dateNum:=Add to date(Current date; 0; 5; 0)
$entité.fct.dateChaine:="vers 2089"
$entité.fct.leLieu.leSite.laCommune.nom:="City les Bains de Pied"
$entité.fct.leLieu.leSite.laCommune.leDepartement.numero:=973
End case
$entité.IDunique:=Generate UUID
End if
$ptrEntité->:=OB Copy($entité)
Function existePersonne($entité : Object)->$result : Integer
$result:=0
Case of
// il y a des restrictions
: (This.paramsArbre.PersonnesAffichables=Null)
// on a les données webables
: (This.paramsArbre.EntitésWebables=Null)
// on a les personnes webables
: (This.paramsArbre.EntitésWebables[This.paramsArbre.PersonnesAffichables]=Null)
// l'enregistrement est affichable
: (This.paramsArbre.EntitésWebables[This.paramsArbre.PersonnesAffichables].indexOf($entité.ID)>-1)
// c'est ok
Else
// données masquées
$result:=-16330
End case
Function existeEvent($entité : Object)->$result : Integer
$result:=0
Case of
: ($entité=Null)
$result:=-16318
// il y a des restrictions
: (This.paramsArbre.EventsAffichables=Null)
// on a les données webables
: (This.paramsArbre.EntitésWebables=Null)
// on a les evennements webables
: (This.paramsArbre.EntitésWebables[This.paramsArbre.EventsAffichables]=Null)
// l'enregistrement est affichable
: (This.paramsArbre.EntitésWebables[This.paramsArbre.EventsAffichables].indexOf($entité.ID)>-1)
// c'est ok
Else
// données masquées
$result:=-16330
End case
⇧
[class]_Trace - 05/01/2026 17:23:47
property cible : cs.xSDK.Traces
property success : Boolean
property paramsArbre : Object
property libellé : Text
singleton Class constructor()
This.cible:=cs.xSDK.Traces.new()
This.success:=False
// ----------------------
//MARK:Wrappers
// ----------------------
Function set Error($numError : Integer)
This.cible.Error:=$numError
Function get Error()->$result : Integer
$result:=This.cible.Error
Function set ErrorDescription($description : Text)
This.cible.ErrorDescription:=$description
Function get ErrorDescription()->$result : Text
$result:=This.cible.ErrorDescription
Function Intercepter()
ErrorNum:=This.cible.Intercepter("ARB"; Error; Error method; Error line; Error formula)
Function Initialiser($nomMethode : Text)->$result : Object
This.cible.CréerErreur("ARB"; 0; $nomMethode; "")
$result:=This
Function Créer($Error : Integer; $nomMethode : Text; $ErrorDescription : Text)->$result : Object
This.cible.CréerErreur("ARB"; $Error; $nomMethode; $ErrorDescription)
$result:=This
Function FixerSuccess()
This.cible.FixerSuccess()
This.success:=This.cible.success
Function LeverException($options : Collection)
// renseigner le label de l'erreur
This.cible.ErrorLabel:=Localized string(String(This.cible.Error))
// lancer le traitement de l'erreur
This.cible.LeverException($options)
Function EnvoyerMessages($options : Collection; $libellé : Text; $source : Text; $description : Text; $contexte : Object)
This.cible.EnvoyerMessages($options; "ARB"; $libellé; $source; $description; $contexte)
// ----------------------
//MARK:DEBUG composant
// ----------------------
Function DebugerMethode($libellé : Text; $source : Text; $description : Text)->$result : Boolean
$result:=This.cible.DebugerMethode(Storage.Host; "ARB"; $libellé; $source; $description)
Function DEBUG_STORE_PICT_BDD_AG($libellé : Text; $params : Object)->$result : Boolean
// revient à appeler "STORE_PICT_BDD_AG_process" depuis un ASSERT (créer une image de l'arbre courant)
// ici on est dans le process appelant (thread-safe) => appeler les functions non thread-safe par un worker
var $paramsArbre; $tablesBDD_AG : Object
// si l'appel à cette fonction est encapsulé dans un ASSERT, renvoyer Vrai, sinon une erreur est générée
$result:=True
// vérifier que le debug est demandé
Case of
: (Not(This.estDebug($params)))
: ($params.EtatProcessus.Params ?? 27)
// le module de dessin utilise des requêtes SQL, il faut se mettre dans un process où c'est possible
// récupérer le contenu de la BDD locale ; les tableaux existent forcément (le debug n'est pas bugué !)
$tablesBDD_AG:=cs.$arbre.new().LireTableauxBDD_AG()
// un seul objet en paramètre !
$paramsArbre:=OB Copy($params)
$paramsArbre.tablesBDD_AG:=$tablesBDD_AG
// faire le dessin dans le worker
CALL WORKER("WK_ArbreGenealogie"; Formula from string("cs._Trace.new()._STORE_PICT_BDD_AG_process($1;$2)"); $libellé; $paramsArbre)
End case
Function _STORE_PICT_BDD_AG_process($libellé : Text; $params : Object)
// ici la mise à jour de la BDD_AG par les requetes SQL est possible
// on est dans un Worker : mettre à jour la BDD_AG SQL avec la BDD_AG TAB
This.InitProcess()
This.libellé:=$libellé
This.paramsArbre:=$params
cs._modification_BDD_AG.new($params).AppliquerDéploiement_AG()
// mémoriser l'image de l'arbre courant
This._STORE_XML_AG()
Function _STORE_XML_AG()
// créer l'image de l'arbre courant et la stocker dans This.libellé
var $structureSVG; $arbreXML : Text
// desiner l'arbre courant
$structureSVG:=""
cs._dessin.new().CréerArbreXML(->$StructureSVG)
// exporter son image
$arbreXML:=DOM Parse XML variable($structureSVG)
This._STORE_refXML($arbreXML; "image/png")
DOM CLOSE XML($arbreXML)
Function _STORE_refXML($arbreXML : Text; $type : Text)
var $dossier : 4D.Folder
var $image : Picture
$dossier:=This.paramsArbre.CheminDossierExport
Case of
: (Not(OB Is defined(This.paramsArbre; "CheminDossierExport")))
: (($type="image/png") | ($type=".png"))
$dossier:=Folder(This.paramsArbre.CheminDossierExport; fk platform path).folder("IDarbre_"+String(This.paramsArbre.IDarbre))
SVG EXPORT TO PICTURE($arbreXML; $image; Copy XML data source)
WRITE PICTURE FILE($dossier.platformPath+This.libellé+".png"; $image; "image/png")
: (($type="Pdf") | ($type=".pdf"))
$dossier:=Folder(This.paramsArbre.CheminDossierExport; fk platform path).folder("IDarbre_"+String(This.paramsArbre.IDarbre))
SVG EXPORT TO PICTURE($arbreXML; $image; Copy XML data source)
CONVERT PICTURE($image; ".pdf")
WRITE PICTURE FILE($dossier.platformPath+This.libellé+".pdf"; $image)
Else
End case
Function DEBUG_STORE_TAB_BDD_AG($libellé : Text; $params : Object)->$result : Boolean
// on est dans le worker, faire une photo de la BDD_AG-TAB et mettre à jour la BDD_AG-SQL hors du worker (qui est thread-safe)
// revient à appeler "Exporter" depuis un ASSERT
// ici on est dans le process appelant (thread-safe) => appeler les functions non thread-safe par un worker
var $paramsArbre; $tablesBDD_AG : Object
// si l'appel à cette fonction est encapsulé dans un ASSERT, renvoyer Vrai, sinon une erreur est générée
$result:=True
// vérifier que le debug est demandé
Case of
: (Not(This.estDebug($params)))
: ($params.EtatProcessus.Params ?? 28)
// récupérer le contenu de la BDD locale ; les tableaux existent forcément (le debug n'est pas bugué !)
$tablesBDD_AG:=cs.$arbre.new().LireTableauxBDD_AG()
// un seul objet en paramètre !
$paramsArbre:=OB Copy($params)
$paramsArbre.tablesBDD_AG:=$tablesBDD_AG
// appeler "WK_ArbreGenealogie"
CALL WORKER("WK_ArbreGenealogie"; Formula from string("cs._Trace.new()._STORE_TAB_BDD_AG_process($1;$2)"); $libellé; $paramsArbre)
End case
Function _STORE_TAB_BDD_AG_process($libellé : Text; $params : Object)
// ici l'accès SQL à la BDD_AG est possible
// faire une photo de la BDD_AG-SQL courante
This.InitProcess()
This.libellé:=$libellé
This.paramsArbre:=$params
If (Not(This.paramsArbre.tablesBDD_AG=Null))
// on est dans le worker : mettre à jour la BDD_AG SQL avec la BDD_AG TAB
cs._modification_BDD_AG.new($params).AppliquerDéploiement_AG()
End if
This._STORE_TAB()
Function _STORE_TAB()
var $dossier : 4D.Folder
var $i; $j : Integer
var $sql_commande; $ligne; $texte; $VarName; $AlertesHôte : Text
var $champs : Collection
var $champ : Object
var $ptr : Pointer
// fixer le chemin du dossier où exporter
$dossier:=Folder(This.paramsArbre.CheminDossierExport; fk platform path).folder("IDarbre_"+String(This.paramsArbre.IDarbre)).folder(This.libellé)
// lire le nom et le type des champs de la table $2
ARRAY TEXT($nomTables; 0)
Begin SQL
SELECT TABLE_NAME FROM _USER_TABLES INTO :$nomTables;
End SQL
// pour toutes les tables
For ($i; 1; Size of array($nomTables))
// lire le nom et le type des champs de la table $i
ARRAY TEXT(nomChamps; 0)
ARRAY LONGINT(typeChamps; 0)
$sql_commande:="SELECT COLUMN_NAME, DATA_TYPE FROM _USER_COLUMNS WHERE TABLE_NAME = '"+$nomTables{$i}+"' INTO :nomChamps, :typeChamps;"
Begin SQL
EXECUTE IMMEDIATE :$sql_commande;
End SQL
// écrire les entêtes
$ligne:=""
For ($j; 1; Size of array(nomChamps))
$ligne:=$ligne+Char(Tab)+nomChamps{$j}
End for
$texte:=Replace string($ligne; Char(Tab); ""; 1; *)+Char(Line feed)
// lire les données des champs
$champs:=New collection
For ($j; 1; Size of array(nomChamps))
// lire les valeurs du champ nomChamps{$j}
Case of
: (typeChamps{$j}=1) // un booléen
ARRAY BOOLEAN(tabBool; 0)
$VarName:="tabBool"
$ptr:=->tabBool
: (typeChamps{$j}=4) // un type entier long
ARRAY LONGINT(tabEntierLong; 0)
$VarName:="tabEntierLong"
$ptr:=->tabEntierLong
: (typeChamps{$j}=6) // un type réel
ARRAY REAL(tabReel; 0)
$VarName:="tabReel"
$ptr:=->tabReel
: ((typeChamps{$j}=10) | (typeChamps{$j}=13)) // un type texte ou UUID
ARRAY TEXT(tabTexte; 0)
$VarName:="tabTexte"
$ptr:=->tabTexte
: (typeChamps{$j}=18) // un type blob (pas gérer par les objets => remplacé par chaine vide)
ARRAY TEXT(tabTexte; 0)
$VarName:="tabTexte"
$ptr:=->tabTexte
End case
// créer la commande de sélection et extraire
// en compilé, il faut des tableaux process, sinon $VarName pas reconnu
$sql_commande:="SELECT "+nomChamps{$j}+" FROM "+$nomTables{$i}+" INTO :"+$VarName+";"
Begin SQL
EXECUTE IMMEDIATE :$sql_commande;
End SQL
If (ok=1)
$champ:=New object("nom"; nomChamps{$j}; "type"; typeChamps{$j})
OB SET ARRAY($champ; "valeurs"; $ptr->)
$champs.push($champ)
End if
End for
// on a pompé la table $nomTables{$i}
// écrire les champs
Case of
: (Not(Asserted($champs.length>0; Current method name+" "+This.libellé+" : pas de champ exporté de la table "+$nomTables{$i})))
Else
$ligne:=""
For ($j; 1; $champs[0].valeurs.length)
For each ($champ; $champs)
Case of
: ($champ.type=1) // un booléen
$ligne:=$ligne+Char(Tab)+String($champ.valeurs[$j-1])
: ($champ.type=4) // un type entier long
$ligne:=$ligne+Char(Tab)+String($champ.valeurs[$j-1])
: ($champ.type=6) // un type réel
$ligne:=$ligne+Char(Tab)+String($champ.valeurs[$j-1]; "#0,000000")
: (($champ.type=10) | ($champ.type=13)) // un type texte ou UUID
$ligne:=$ligne+Char(Tab)+$champ.valeurs[$j-1]
: ($champ.type=18) // un type blob (pas gérer par les objets => remplacé par chaine vide)
$ligne:=$ligne+Char(Tab)
End case
End for each
End for
// supprimer la première tabulation
$texte:=$texte+Replace string($ligne; Char(Tab); ""; 1; *)+Char(Line feed)
End case
TEXT TO DOCUMENT($dossier.platformPath+"Table "+$nomTables{$i}+".txt"; $texte; "UTF-8"; Document with native format)
End for
// on a pompé la BDD
$AlertesHôte:=This.paramsArbre.AlertesHôte
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; This.libellé; Current method name; "dans "+$dossier.platformPath; New object("nomProcess"; Current process name; "numProcess"; Current process))
Function estDebug($params : Object)->$result : Boolean
$result:=($params.Session_Etat ?? 8)
Function InitProcess()
ErrorNum:=0
ON ERR CALL(Formula(traceHandler).source) // gestion des erreurs
⇧
[class]_dessin - 02/08/2026 12:19:49
property structureXML; racineXML : Text
property IDarbre; IDcalque; IDcadre : Integer
property FormatsInformation : Object
Class extends $arbre
Class constructor($params : Object)
Super($params)
This.structureXML:=""
This.IDarbre:=0
This.IDcalque:=0
Super.FixerSQL_BDDpath()
Super.OuvrirBDD_Externe()
// ----------------------
// MARK:Structure XML
// ----------------------
Function CréerArbreXML($ptrStructureXML : Pointer)
// créer la structure XML de l'arbre généalogique this.paramsArbre.IDarbre
var $arbreXML : Text
var $IDarbre; $i : Integer
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; "Dessin"; Current method name; "Initialisation"; New object("nomProcess"; Current process name; "numProcess"; Current process))
This.IDarbre:=This.paramsArbre.IDarbre
// initialiser la structure XML
This.InitialiserArbreXML($ptrStructureXML)
// ajouter l'arbre au document SVG This.structureXML
$arbreXML:=DOM Parse XML variable($ptrStructureXML->)
// chercher tous les calques
$IDarbre:=This.paramsArbre.IDarbre
ARRAY LONGINT($tabCalques; 0)
Begin SQL
SELECT id FROM calques WHERE id IN
(SELECT DISTINCT calque FROM cadres WHERE cadres.arbre = :$IDarbre)
ORDER BY num_ordre INTO :$tabCalques;
End SQL
ASSERT(Size of array($tabCalques)>0; Current method name+" : pas de calque à dessiner")
// * dessiner les calques
This.paramsArbre.EtatProcessus.Params:=This.paramsArbre.EtatProcessus.Params & 0xFFFFFFE3 // raz options
This.paramsArbre.EtatProcessus.Params:=This.paramsArbre.EtatProcessus.Params ?+ 2 // dessiner les éléments
For ($i; 1; Size of array($tabCalques))
// se déroule dans le process courant
This.IDcalque:=$tabCalques{$i}
This.DessinerCalque(->$arbreXML)
End for
// bit 25 = afficher l'arbre dans le viewer 4D, pour debug
If (This.paramsArbre.EtatProcessus.Params ?? 25)
// pour être thread-safe
ALERT(Current method name+" 2026-02-03 utiliser Function AfficherViewer()")
EXECUTE METHOD("SVGTool_Display_viewer")
EXECUTE METHOD("SVGTool_SHOW_IN_VIEWER"; *; $arbreXML)
DOM EXPORT TO FILE($arbreXML; Get 4D folder(Logs folder)+"testStructureSVG.xml")
End if
// c'est fini : renvoyer le document XML
DOM EXPORT TO VAR($arbreXML; $ptrStructureXML->)
DOM CLOSE XML($arbreXML)
Function DessinerCalque($ptrArbreXML : Pointer)
// dessiner tous les cadres du calque IDcalque dans la structure XML $2
var $IDarbre; $numCalque; $i; $IDcalque : Integer
var $blob : Blob
var $style : Object
var $texte; $ElementXML : Text
// variables pour les requêtes SQL
$IDarbre:=This.IDarbre
$IDcalque:=This.IDcalque
// récupérer les données du calque
Begin SQL
SELECT num_ordre, style FROM calques WHERE id = :$IDcalque INTO :$numCalque, :$blob;
End SQL
// ajouter les styles de ce calque
BLOB TO VARIABLE($blob; $style) // si pas de style, $style n'est pas défini
If (OB Is defined($style))
$texte:=This.TextualiserStyles($style)
$texte:=".calque"+String($numCalque)+$texte // un "." pour un style de classe (cf CSS)
$ElementXML:=DOM Create XML element($ptrArbreXML->; "svg/defs/style"; "id"; "styleCalque"+String($numCalque); "type"; "text/css")
DOM SET XML ELEMENT VALUE($ElementXML; $texte; *) // valeur = CDATA
End if
// sélectionner les cadres du calque
ARRAY LONGINT($tabID; 0)
Begin SQL
SELECT id FROM cadres WHERE arbre = :$IDarbre AND calque = :$IDcalque INTO :$tabID;
End SQL
ASSERT(Size of array($tabID)>0; Current method name+" : pas de cadre à dessiner")
// dessiner les cadres du calque
For ($i; 1; Size of array($tabID))
This.IDcadre:=$tabID{$i}
This.DessinerCadre($ptrArbreXML)
End for
Function DessinerCadre($ptrArbreXML : Pointer)
var $options; $IDcadre; $IDcalque; $numOrdre; $IDobjetBDD; $typeElement; $i; $j; $typeInfo; $orientation; $épaisseur : Integer
var $gauche; $haut; $largeur; $hauteur; $rotation : Real
var $deployed; $initDessin : Boolean
var $UUID; $Xpath; $arbreXML; $ElementXML; $EnfantXML; $PetitEnfantXML; $svgInformation; $texte; $taille : Text
var $EtatProcessus; $data; $style; $information : Object
var $blob : Blob
$EtatProcessus:=This.paramsArbre.EtatProcessus
// structure de l'arbre modifiée localement
$arbreXML:=$ptrArbreXML->
// variables pour les requêtes SQL
$IDcadre:=This.IDcadre
$IDcalque:=0
Begin SQL
SELECT id_objet_BDD, uuid_objet_BDD, type_element, gauche, haut, largeur, hauteur, rotation, data, deployed, init_dessin, calque, arbre FROM cadres WHERE id = :$IDcadre INTO :$IDobjetBDD, :$UUID, :$typeElement, :$gauche, :$haut, :$largeur, :$hauteur, :$rotation, :$blob, :$deployed, :$initDessin, :$IDcalque, :$options;
SELECT options FROM arbres WHERE id = :$options INTO :$options;
SELECT num_ordre FROM calques WHERE id = :$IDcalque INTO :$numOrdre;
End SQL
BLOB TO VARIABLE($blob; $data)
// rappel : $data contient un tableau d'objets (les informations), chaque information contient :
// v9.0.7
// . "typeInfo"
// . "orientation"
// . "positionX"
// . "positionY"
// . "Options"
// . "FormatDate"
// masquer les cadres bidon (code enregistrement = 204)
// on les met sur un calque spécifique (non visible via les CSS)
$numOrdre:=Choose(CodeEnreg($IDobjetBDD)=204; -1; $numOrdre)
// lire la structure
DOM GET XML ELEMENT NAME($arbreXML; $Xpath) // récupérer la racine
$Xpath:="/"+$Xpath
If (ok=1)
// créer un groupe d'informations et fixer son rotation
If (($rotation=90) | ($rotation=-90))
$ElementXML:=DOM Create XML element($arbreXML; $Xpath+"/g"; "id"; $IDobjetBDD; "UUID"; $UUID; "typeElement"; $typeElement; "transform"; "translate("+String($gauche; "&xml")+","+String($haut+$hauteur; "&xml")+") rotate("+String($rotation; "&xml")+")"; "class"; "calque"+String($numOrdre))
Else
$ElementXML:=DOM Create XML element($arbreXML; $Xpath+"/g"; "id"; $IDobjetBDD; "UUID"; $UUID; "typeElement"; $typeElement; "transform"; "translate("+String($gauche; "&xml")+","+String($haut; "&xml")+")"; "class"; "calque"+String($numOrdre))
End if
If ($deployed)
// le cadre est déployé (définitivement positionné dans l'arbre)
// * dessiner les informations du cadre
If ($initDessin)
// * il y a des choses à dessiner ?
Case of
: (Not(OB Is defined($data; "informations")))
: ($data.informations.length=0)
Else
// Ok on y va
For each ($information; $data.informations)
This.FormatsInformation:=$information
$typeInfo:=This.FormatsInformation.typeInfo
$EnfantXML:=DOM Create XML element($ElementXML; "g"; "id"; String($IDobjetBDD)+"_"+String($typeInfo); "class"; "Element"+String($typeElement)+"_info"+String($typeInfo); "formatInfo"; This.FormatsInformation.Options)
// ajouter l'information
// important : en final l'info doit être dans $svgInformation (cf § les styles)
$svgInformation:=""
Case of
: ($typeInfo=2051)
// mettre un cadre
$épaisseur:=0
This.LireStyleElement(This.IDarbre; "Element"+String($typeElement)+"_info"+String($typeInfo); "stroke-width"; ->$épaisseur)
If ($EtatProcessus.Params ?? 2)
// dessiner le rect du cadre. Doit être inclus dans le cadre
$svgInformation:=DOM Create XML element($EnfantXML; "rect"; "x"; $épaisseur/2; "y"; $épaisseur/2; "width"; $largeur-$épaisseur; "height"; $hauteur-$épaisseur)
End if
Case of
: ($EtatProcessus.Params ?? 3)
// * créer le rect du rect
$PetitEnfantXML:=DOM Create XML element($EnfantXML; "rect"; "class"; "CadreElement"; "id"; String($IDobjetBDD)+"_"+String($typeInfo)+"_CadreInformation"; "x"; 0; "y"; 0; "width"; $largeur; "height"; $hauteur; "visibility"; "hidden")
: ($EtatProcessus.Params ?? 4)
// pas d'ancre pour cette information
End case
: ($typeInfo=2052)
// dessiner un tracé ZigZag calculé
// * récupérer la position des connecteurs du cadre ; en 2 coups (la connexion d'origine, puis les connexions aval)
ARRAY REAL($tabXreduit; 0)
ARRAY REAL($tabYreduit; 0)
ARRAY REAL($tabDirection; 0)
ARRAY REAL($tabXreduit_Aval; 0)
ARRAY REAL($tabYreduit_Aval; 0)
ARRAY REAL($tabDirection_Aval; 0)
Begin SQL
SELECT x_reduit_lie, y_reduit_lie, direction FROM connexions WHERE cadre_lie = :$IDcadre INTO :$tabXreduit, :$tabYreduit, :$tabDirection;
SELECT x_reduit, y_reduit, direction FROM connexions WHERE cadre = :$IDcadre ORDER BY num_logic ASC INTO :$tabXreduit_Aval, :$tabYreduit_Aval, :$tabDirection_Aval;
End SQL
// pas glop : sommer les tableaux à la main
For ($j; 1; Size of array($tabXreduit_Aval))
APPEND TO ARRAY($tabXreduit; $tabXreduit_Aval{$j})
APPEND TO ARRAY($tabYreduit; $tabYreduit_Aval{$j})
APPEND TO ARRAY($tabDirection; $tabDirection_Aval{$j})
End for
// il faut au moins 2 connecteurs
This.trace.Créer(-16310*Num(Size of array($tabXreduit)<2); Current method name; "le cadre "+String($IDcadre)+" n'a qu'un connecteur pour le tracé").LeverException([msgk_event; msgk_log])
If (Size of array($tabXreduit)>0)
// créer la chaine de commande du tracé calculé
$texte:=""
For ($j; 1; Size of array($tabXreduit))
// Rappels :
// - la position des connecteurs est centrée / réduite dans le repère cadre
// - Tracé : M = move to en absolu, v line to, suivant x, vers un point relatif au départ, h line to, suivant y, vers un point relatif au départ
// tracer du centre du cadre vers le connecteur j en zig puis zag
$texte:=$texte+" M"+String($largeur/2; "&xml")+" "+String($hauteur/2; "&xml") // se placer au centre du rectangle
Case of
: (($tabDirection{1}=0) | ($tabDirection{1}=180))
// connecteur horizontal
$texte:=$texte+" v0 "+String($tabYreduit{$j}*$hauteur; "&xml") // le zig vertical
$texte:=$texte+" h"+String($tabXreduit{$j}*$largeur; "&xml")+" 0" // le zag horizontal
// connecteur vertical
: (($tabDirection{1}=90) | ($tabDirection{1}=270))
$texte:=$texte+" h"+String($tabXreduit{$j}*$largeur; "&xml")+" 0" // le zig horizontal
$texte:=$texte+" v0 "+String($tabYreduit{$j}*$hauteur; "&xml") // le zag vertical
End case
End for
$texte:=$texte+" M"+String($largeur/2; "&xml")+" "+String($hauteur/2; "&xml")+" z" // revenir au centre du rectangle et fermer
Case of
: ($EtatProcessus.Params ?? 3)
// * créer le rect du tracé
SORT ARRAY($tabXreduit; >)
$gauche:=(0.5+$tabXreduit{1})*$largeur
$tabXreduit{0}:=(0.5+$tabXreduit{Size of array($tabXreduit)})*$largeur-$gauche
SORT ARRAY($tabYreduit; >)
$haut:=(0.5+$tabYreduit{1})*$hauteur
$tabYreduit{0}:=(0.5+$tabYreduit{Size of array($tabYreduit)})*$hauteur-$haut
$PetitEnfantXML:=DOM Create XML element($EnfantXML; "rect"; "class"; "CadreElement"; "id"; String($IDobjetBDD)+"_"+String($typeInfo)+"_CadreInformation"; "x"; $gauche; "y"; $haut; "width"; $tabXreduit{0}; "height"; $tabYreduit{0}; "visibility"; "hidden")
: ($EtatProcessus.Params ?? 4)
// pas d'ancre pour cette information
End case
If ($EtatProcessus.Params ?? 2)
// écrire le tracé
$svgInformation:=DOM Create XML element($EnfantXML; "path"; "d"; $texte; "fill"; "none") // forcer le fill
End if
End if
: ($typeInfo=2053)
// dessiner un tracé en étoile calculé
// * récupérer la position des connecteurs du cadre
ARRAY REAL($tabXreduit; 0)
ARRAY REAL($tabYreduit; 0)
ARRAY REAL($tabXreduit_Aval; 0)
ARRAY REAL($tabYreduit_Aval; 0)
Begin SQL
SELECT x_reduit_lie, y_reduit_lie FROM connexions WHERE cadre_lie = :$IDcadre INTO :$tabXreduit, :$tabYreduit;
SELECT x_reduit, y_reduit FROM connexions WHERE cadre = :$IDcadre ORDER BY num_logic ASC INTO :$tabXreduit_Aval, :$tabYreduit_Aval;
End SQL
// pas glop : sommer les tableaux à la main
For ($j; 1; Size of array($tabXreduit_Aval))
APPEND TO ARRAY($tabXreduit; $tabXreduit_Aval{$j})
APPEND TO ARRAY($tabYreduit; $tabYreduit_Aval{$j})
End for
// il faut 2 connecteurs
This.trace.Créer(-16310*Num(Size of array($tabXreduit)<2); Current method name; "le cadre "+String($IDcadre)+" n'a pas 2 connecteurs pour le tracé").LeverException([msgk_event; msgk_log])
If (Size of array($tabXreduit)=2)
// créer la chaine de commande du tracé calculé
$texte:=""
For ($j; 1; Size of array($tabXreduit))
// Rappels :
// - la position des connecteurs est centrée / réduite dans le repère cadre
// - Tracé : M = move to en absolu, l line to vers un point x, y relatif au départ
// tracer du centre du cadre vers le connecteur j en direct
$texte:=$texte+" M"+String($largeur/2; "&xml")+" "+String($hauteur/2; "&xml") // se placer au centre du rectangle
$texte:=$texte+" l "+String($tabXreduit{$j}*$largeur; "&xml")+" "+String($tabYreduit{$j}*$hauteur; "&xml")
End for
$texte:=$texte+" M"+String($largeur/2; "&xml")+" "+String($hauteur/2; "&xml")+" z" // revenir au centre du rectangle et fermer
Case of
: ($EtatProcessus.Params ?? 3)
// * créer le rect du tracé
SORT ARRAY($tabXreduit; >)
$gauche:=(0.5+$tabXreduit{1})*$largeur
$tabXreduit{0}:=(0.5+$tabXreduit{Size of array($tabXreduit)})*$largeur-$gauche
SORT ARRAY($tabYreduit; >)
$haut:=(0.5+$tabYreduit{1})*$hauteur
$tabYreduit{0}:=(0.5+$tabYreduit{Size of array($tabYreduit)})*$hauteur-$haut
$PetitEnfantXML:=DOM Create XML element($EnfantXML; "rect"; "class"; "CadreElement"; "id"; String($IDobjetBDD)+"_"+String($typeInfo)+"_CadreInformation"; "x"; $gauche; "y"; $haut; "width"; $tabXreduit{0}; "height"; $tabYreduit{0}; "visibility"; "hidden")
: ($EtatProcessus.Params ?? 4)
// pas d'ancre pour cette information
End case
If ($EtatProcessus.Params ?? 2)
// écrire le tracé
$svgInformation:=DOM Create XML element($EnfantXML; "path"; "d"; $texte; "fill"; "none") // forcer le fill
End if
End if
: ($typeInfo=201)
// mettre une image
: ((($typeInfo>2040) & ($typeInfo<2050)) | (($typeInfo>=20000) & ($typeInfo<=39999)))
// récupérer la taille de la police
// écrire un texte
$taille:=""
This.LireStyleElement(This.IDarbre; "Element"+String($typeElement)+"_info"+String($typeInfo); "font-size"; ->$taille)
$gauche:=This.FormatsInformation.positionX
$haut:=This.FormatsInformation.positionY
Case of
: ($EtatProcessus.Params ?? 3)
// * créer le rect du texte
$PetitEnfantXML:=DOM Create XML element($EnfantXML; "rect"; "class"; "CadreElement"; "id"; String($IDobjetBDD)+"_"+String($typeInfo)+"_CadreInformation"; "x"; 0; "y"; 0; "width"; $largeur-$gauche; "height"; $taille; "visibility"; "hidden")
: ($EtatProcessus.Params ?? 4)
// * créer les ancres de repositionnnement de l'info
$PetitEnfantXML:=DOM Create XML element($EnfantXML; "g"; "id"; String($IDobjetBDD)+"_"+String($typeInfo)+"_CadreInformationAncres"; "visibility"; "hidden"; "transform"; "translate(0,0)")
$texte:=DOM Create XML element($PetitEnfantXML; "rect"; "class"; "AncreCadre"; "id"; String($IDobjetBDD)+"_"+String($typeInfo)+"_CadreInformationAncresReposGH"; "x"; -Taille ancre; "y"; -Taille ancre; "width"; Taille ancre; "height"; Taille ancre)
$texte:=DOM Create XML element($PetitEnfantXML; "rect"; "class"; "AncreCadre"; "id"; String($IDobjetBDD)+"_"+String($typeInfo)+"_CadreInformationAncresReposDH"; "x"; $largeur-$gauche; "y"; -Taille ancre; "width"; Taille ancre; "height"; Taille ancre)
$texte:=DOM Create XML element($PetitEnfantXML; "rect"; "class"; "AncreCadre"; "id"; String($IDobjetBDD)+"_"+String($typeInfo)+"_CadreInformationAncresReposGB"; "x"; -Taille ancre; "y"; $taille; "width"; Taille ancre; "height"; Taille ancre)
$texte:=DOM Create XML element($PetitEnfantXML; "rect"; "class"; "AncreCadre"; "id"; String($IDobjetBDD)+"_"+String($typeInfo)+"_CadreInformationAncresReposDB"; "x"; $largeur-$gauche; "y"; $taille; "width"; Taille ancre; "height"; Taille ancre)
End case
// * fixer la position / rotation de l'information
$orientation:=This.FormatsInformation.orientation
// rmk : l'origine d'un rect est le coin gauche/haut, l'origine d'un text est gauche/bas, l'origine d'un textArea est gauche/haut => "CadreElement" a la même origine que le texte
Case of
: ($orientation=0)
DOM SET XML ATTRIBUTE($EnfantXML; "transform"; "translate("+String($gauche; "&xml")+","+String($haut; "&xml")+") rotate("+String($orientation; "&xml")+")")
: ($orientation=-90)
DOM SET XML ATTRIBUTE($EnfantXML; "transform"; "translate("+String($haut; "&xml")+","+String($hauteur-$gauche; "&xml")+") rotate("+String($orientation; "&xml")+")")
: ($orientation=90)
DOM SET XML ATTRIBUTE($EnfantXML; "transform"; "translate("+String($largeur-$haut; "&xml")+","+String($gauche; "&xml")+") rotate("+String($orientation; "&xml")+")")
Else
// non traité
This.trace.Créer(-16310; Current method name; "l'orientation "+String($orientation)+"de l'information "+String($i)+" n'est pas gérée").LeverException([msgk_event; msgk_log])
End case
// * on veut les cadres
If ($EtatProcessus.Params ?? 2)
// * ajouter l'information
This.DessinerInformation(->$EnfantXML; ->$IDobjetBDD; ->$options)
End if
Else
This.trace.Créer(-16310; Current method name; "le type d'info "+String($typeInfo)+" de l'information n'est pas géré").LeverException([msgk_event; msgk_log])
End case
If ($EtatProcessus.Params ?? 2)
// ajouter les styles de l'information
If ($svgInformation#"")
If (This.FormatsInformation.styles#Null) // on peut ne pas avoir de styles
$style:=This.FormatsInformation.styles
ARRAY TEXT($propriétés; 0)
OB GET PROPERTY NAMES($style; $propriétés)
For ($j; 1; Size of array($propriétés))
DOM SET XML ATTRIBUTE($svgInformation; $propriétés{$j}; OB Get($style; $propriétés{$j}))
End for
End if
End if
End if
End for each
End case
Else
If ($EtatProcessus.Params ?? 2)
// pour ce bâtard, changer les styles
$EnfantXML:=DOM Create XML element($ElementXML; "rect"; "class"; "UnDrawnElement"; "x"; "0"; "y"; "0"; "width"; $largeur; "height"; $hauteur)
End if
End if
// traiter les options de représentation de l'arbre
If ($EtatProcessus.Params ?? 2)
// bit 26 = dessiner l'Id des cadres, pour debug
If ($EtatProcessus.Params ?? 26)
$texte:=String($IDcadre)+"("+String($typeElement)+")"+" "+String($IDobjetBDD & 0x00FFFFFF)+"("+String($IDobjetBDD >> 24)+")"
$EnfantXML:=SVG_New_text($ElementXML; $texte; 0; 0; "Arial"; 16)
End if
// bit 24 = pour debug : dessiner les connexions utilisées, l'ID des connecteurs
If ($EtatProcessus.Params ?? 24)
ARRAY LONGINT($tabID; 0)
ARRAY REAL($tabXreduit; 0)
ARRAY REAL($tabYreduit; 0)
Begin SQL
SELECT id, x_reduit_lie, y_reduit_lie FROM connexions WHERE cadre_lie = :$IDcadre INTO :$tabID, :$tabXreduit, :$tabYreduit;
End SQL
$EnfantXML:=SVG_New_circle($ElementXML; ($tabXreduit{1}+0.5)*$largeur; ($tabYreduit{1}+0.5)*$hauteur; 2; "blue"; "blue"; 1)
$EnfantXML:=SVG_New_text($ElementXML; String($tabID{1})+"-cadre"+String($IDcadre); ($tabXreduit{1}+0.5)*$largeur+4; ($tabYreduit{1}+0.5)*$hauteur; "Arial"; 10)
Begin SQL
SELECT id, x_reduit, y_reduit FROM connexions WHERE cadre = :$IDcadre INTO :$tabID, :$tabXreduit, :$tabYreduit;
End SQL
For ($i; 1; Size of array($tabXreduit))
$EnfantXML:=SVG_New_circle($ElementXML; ($tabXreduit{$i}+0.5)*$largeur; ($tabYreduit{$i}+0.5)*$hauteur; 5; "coral"; "coral"; 1)
$EnfantXML:=SVG_New_text($ElementXML; String($tabID{$i})+"-cadre"+String($IDcadre); ($tabXreduit{$i}+0.5)*$largeur+4; ($tabYreduit{$i}+0.5)*$hauteur+10; "Arial"; 10)
End for
End if
End if
Else
// le cadre est positionné (provisoirement) ou non dans l'arbre
If ($EtatProcessus.Params ?? 2)
// pour ce bâtard, surcharger les styles de la classe
$EnfantXML:=DOM Create XML element($ElementXML; "rect"; "class"; "UnDeployedElement"; "x"; "0"; "y"; "0"; "width"; $largeur; "height"; $hauteur)
If ($EtatProcessus.Params ?? 26)
$EnfantXML:=SVG_New_text($ElementXML; String($IDcadre); 0; 0; "Arial"; 20)
End if
End if
End if
End if
// renvoyer la nouvelle structure
$ptrArbreXML->:=$arbreXML
Function DessinerInformation($EnfantXML : Pointer; $IDobjetBDD : Pointer; $options : Pointer)
// $1 = ptr paramsArbre, $2 = ptr Element, $3 = ptr IDobjetCodé de la BDD, $4 = ptr information, $5 = ptr options
// dessiner la valeur issue de la BDD ou de données par défaut
var $typeInfo; $Error : Integer
var $ElementXML; $informationFormatée : Text
var $entité; $formats : Object
$typeInfo:=This.FormatsInformation.typeInfo
$formats:=New object()
$formats.Options:=OB Get(This.FormatsInformation; "Options"; Is longint) // forcer le typage
$formats.FormatDate:=OB Get(This.FormatsInformation; "FormatDate"; Is longint)
$formats.FormatHeure:=OB Get(This.FormatsInformation; "FormatHeure"; Is longint)
$formats.SymbolDateLieu:=" - " // en DUR
Case of
: ($typeInfo=29000)
// données composites d'une personne $IDobjetBDD
$informationFormatée:=" - "
// lire les données de naissance
Case of
: (cs.BioData.me.Chercher($IDobjetBDD->; 22000; ->$entité)#0)
: ($entité=Null)
Else
$informationFormatée:=$entité.Libellé($formats)+$informationFormatée
End case
// lire les données de décès
Case of
: (cs.BioData.me.Chercher($IDobjetBDD->; 22100; ->$entité)#0)
: ($entité=Null)
Else
$informationFormatée:=$informationFormatée+$entité.Libellé($formats)
End case
If ($informationFormatée#"")
$ElementXML:=DOM Create XML element($EnfantXML->; "text"; "x"; 0; "y"; "0"; "stroke"; "none") // hauteur variable, forcer le stroke
If (ok=1)
DOM SET XML ELEMENT VALUE($ElementXML; $informationFormatée)
End if
End if
Else
// cas normal
// ici, $IDobjetBDD est une personne ou une union
$Error:=cs.BioData.me.Chercher($IDobjetBDD->; $typeInfo; ->$entité)
// données valides : créer le texte
// rappel : $erreur = -16330 indique une entité non webable
$ElementXML:=$EnfantXML->
// option 2 : créer le lien HTML dynamique sur les personnes affichables
// option 3 : créer le lien HTML statique sur les personnes affichables
// option 4 : créer le lien Mobile Action sur les personnes affichables
Case of
: ($options-> ?? 2) & ($typeInfo=2041)
If ($Error=0)
// personne affichable : créer son lien dynamique
// v5.3 : xlink:href est déclaré obsolète dans SVG v2; il faut utiliser href (pas encore reconnu par Safari ! => on met les 2)
$ElementXML:=DOM Create XML element($ElementXML; "a"; "target"; "_top"; "href"; "/4DCGI/Web/AfficherArbre"+This.paramsArbre.SéparateurParamsURL+$entité.IDunique; "xlink:href"; "/4DCGI/Web/AfficherArbre"+This.paramsArbre.SéparateurParamsURL+$entité.IDunique)
Else
// remettre à 0 pour écrire l'information sans lien
$Error:=0
End if
: ($options-> ?? 3) & ($typeInfo=2041)
If ($Error=0)
// personne affichable : créer son lien statique
$informationFormatée:=Lowercase($entité.patronyme)
$informationFormatée:=Substring($informationFormatée; 1; 1)
$ElementXML:=DOM Create XML element($ElementXML; "a"; "target"; "_top"; "href"; "../../personnes/"+$informationFormatée+"/id_"+String($IDobjetBDD->)+".html"; "xlink:href"; "../../personnes/"+$informationFormatée+"/id_"+String($IDobjetBDD->)+".html")
Else
// remettre à 0 pour écrire l'information sans lien
$Error:=0
End if
: ($options-> ?? 4) & ($typeInfo=2041)
If ($Error=0)
// personne affichable : créer son lien dynamique
$ElementXML:=DOM Create XML element($ElementXML; "a"; "target"; "_top"; "href"; "/4DACTION/mobileArbreAfficher"+This.paramsArbre.SéparateurParamsURL+"Personnes"+This.paramsArbre.SéparateurParamsURL+String($IDobjetBDD-> & 0x00FFFFFF))
Else
// remettre à 0 pour écrire l'information sans lien
$Error:=0
End if
: ($options-> ?? 5) & ($typeInfo=2041)
If ($Error=0)
// personne affichable : créer son lien dynamique
$ElementXML:=DOM Create XML element($ElementXML; "a"; "target"; "_top"; "href"; "/4DACTION/ACTION/menuAfficherArbre"+This.paramsArbre.SéparateurParamsURL+"Personnes"+This.paramsArbre.SéparateurParamsURL+$entité.IDunique)
Else
// remettre à 0 pour écrire l'information sans lien
$Error:=0
End if
End case
Case of
: ($Error#0)
: ($entité=Null)
// ex un event inexistant
Else
// dessiner l'information
//$ElementXML:=DOM Créer élément XML($ElementXML;"text";"x";0;"y";"0";"textLength";$largeur-$gauche;"lengthAdjust";"spacingAndGlyphs";"stroke";"none") // hauteur variable, forcer le stroke
$ElementXML:=DOM Create XML element($ElementXML; "text"; "x"; 0; "y"; "0"; "stroke"; "none") // hauteur variable, forcer le stroke
If (ok=1)
// les données sont dans $entité
$informationFormatée:=$entité.Libellé($formats)
DOM SET XML ELEMENT VALUE($ElementXML; $informationFormatée)
End if
End case
End case
// ----------------------
// MARK:Initialisation
// ----------------------
Function InitialiserArbreXML($ptrStructureXML : Pointer)
// initialiser le document this.structureXML
var $arbreXML; $ElementXML; $texte : Text
var $IDarbre; $largeur; $hauteur; $i : Integer
var $styles : Object
var $blob : Blob
This.ParametrerDessinDeArbre()
$IDarbre:=This.paramsArbre.IDarbre
// créer le document SVG
$arbreXML:=DOM Create XML Ref("svg"; "http://www.w3.org/2000/svg"; "xmlns:xlink"; "http://www.w3.org/1999/xlink")
DOM SET XML DECLARATION($arbreXML; "utf-8"; True)
// calculer la taille de la viewbox (marge de 5 px à droite et en bas)
Begin SQL
SELECT MAX(gauche+largeur), MAX(haut+hauteur) FROM cadres WHERE arbre = :$IDarbre AND deployed = TRUE INTO :$largeur, :$hauteur;
End SQL
$largeur:=$largeur+5
$hauteur:=$hauteur+5
DOM SET XML ATTRIBUTE($arbreXML; "version"; "1.1"; "preserveAspectRatio"; "none"; "width"; "100%"; "height"; "100%"; "viewBox"; "0 0 "+String($largeur)+" "+String($hauteur))
// écrire les entêtes
$ElementXML:=DOM Create XML element($arbreXML; "title")
DOM SET XML ELEMENT VALUE($ElementXML; "Arbre généalogique ID "+String($IDarbre))
$ElementXML:=DOM Create XML element($arbreXML; "metadata/generator")
DOM SET XML ELEMENT VALUE($ElementXML; "Composant ALV arbres - Dessiner Arbre")
$ElementXML:=DOM Create XML element($arbreXML; "metadata/about")
DOM SET XML ELEMENT VALUE($ElementXML; "Ainsi La Vie v6.0")
$ElementXML:=DOM Create XML element($arbreXML; "metadata/generation"; "date"; String(Current date; ISO date GMT; Current time); "4D"; Application version)
// fixer le style des éléments non gérés par l'utilisateur, CABLÉ EN DUR !!!
$ElementXML:=DOM Create XML element($arbreXML; "defs/style"; "id"; "styleEdition"; "type"; "text/css")
$texte:="rect.AncreCadre{fill:blue;fill-opacity:1.0;stroke:blue;stroke-width:2}"
$texte:=$texte+".CadreElement{fill:white;stroke:red;stroke-width:2}"
$texte:=$texte+".CadreInformation{fill:green;fill-opacity:"+String(Num(Opacité Remplissage CadreInformation); "&xml")+";stroke:red;stroke-width:2}"
$texte:=$texte+".UnDeployedElement{fill:none;fill-opacity:"+String(Num(Opacité Remplissage CadreInformation); "&xml")+";stroke:red;stroke-width:1;stroke-opacity:0.1;visibility:visible}"
$texte:=$texte+".UnDrawnElement{fill:grey;fill-opacity:0.1;stroke:grey;stroke-width:2;stroke-opacity:1.0;visibility:visible}"
DOM SET XML ELEMENT VALUE($ElementXML; $texte; *) // valeur = CDATA
// fixer le style des informations d'éléments
// le modèle de l'arbre a des styles : les inclure dans la structure SVG (styles internes)
// 'FeuilleStyles' est défini dans les paramètres : faire un lien vers cette ressource (styles externes)
// sinon, la structure qui contient <svg> a un lien vers un fichiers de styles (styles externes) => ne rien faire
// cas du serveur Web avec v5.3 (le link dans la page HTML suffit)
If (This.paramsArbre.FeuilleStyles#Null)
// faire le lien externe (cf SVG v2, 2 possibilités : xlink et import)
$ElementXML:=DOM Create XML element($arbreXML; "style")
DOM SET XML ELEMENT VALUE($ElementXML; "@import url("+This.paramsArbre.FeuilleStyles+");")
// attention : cette option fait planter le viewerSVG de 4D
Else
// les styles sont internes à la structure XML
Begin SQL
SELECT style FROM arbres WHERE id = :$IDarbre INTO :$blob;
End SQL
BLOB TO VARIABLE($blob; $styles)
ARRAY TEXT($propriétés; 0)
OB GET PROPERTY NAMES($styles; $propriétés)
// rappel : il peut ne pas y en avoir
For ($i; 1; Size of array($propriétés))
$texte:=This.TextualiserStyles($styles[$propriétés{$i}])
$texte:="."+$propriétés{$i}+$texte // un "." pour un style de classe (cf CSS)
$ElementXML:=DOM Create XML element($arbreXML; "defs/style"; "id"; "style"+$propriétés{$i}; "type"; "text/css")
DOM SET XML ELEMENT VALUE($ElementXML; $texte; *) // valeur = CDATA
End for
End if
// dessiner le cadre de l'arbre si mode édition du modèle
If ((This.paramsArbre.EtatProcessus.Params & 0x0003)=3)
$ElementXML:=DOM Create XML element($arbreXML; "rect"; "x"; "0"; "y"; "0"; "width"; $largeur; "height"; $hauteur; "visibility"; "visible"; "fill"; "pink"; "fill-opacity"; "0.1")
End if
// init finie
DOM EXPORT TO VAR($arbreXML; $ptrStructureXML->)
DOM CLOSE XML($arbreXML)
Function ParametrerDessinDeArbre()
// fixer le style des informations des éléments
var $IDarbre; $ID; $i; $j : Integer
var $dataTexte; $Xpath; $ElementXML : Text
var $styles; $style : Object
var $blob : Blob
$IDarbre:=This.paramsArbre.IDarbre
//-- récupérer le modèle
$dataTexte:=""
Begin SQL
SELECT modele FROM arbres WHERE id = :$IDarbre INTO :$dataTexte;
End SQL
// * lister tous les éléments du modèle
This.racineXML:=DOM Parse XML variable($dataTexte)
If (ok=1)
DOM GET XML ELEMENT NAME(This.racineXML; $Xpath)
$Xpath:="/"+$Xpath
ARRAY TEXT($élémentsList; 0)
$ElementXML:=DOM Find XML element(This.racineXML; $xPath+"/modele/element"; $élémentsList)
For ($i; 1; Size of array($élémentsList))
DOM GET XML ATTRIBUTE BY NAME($élémentsList{$i}; "id"; $ID)
// * lister toutes les informations possibles de l'élément
ARRAY TEXT($informationsList; 0)
$ElementXML:=DOM Find XML element($élémentsList{$i}; "informationsList/information"; $informationsList)
// rmk : la liste des styles est fixée par "DataArbre", leur valeur par les menus contextuels
For ($j; 1; Size of array($informationsList))
// * lister les styles de l'information
$style:=This.LireStylesDuModeleElement($informationsList{$j})
$ElementXML:=DOM Find XML element($informationsList{$j}; "typeInfo")
DOM GET XML ELEMENT VALUE($ElementXML; $dataTexte)
// l'info type $dataTexte de l'élément id $ID aura pour classe "ElementIDelement_infoTypeInfo"
OB SET($styles; "Element"+String($ID)+"_info"+$dataTexte; $style)
End for
End for
// enregistrer
VARIABLE TO BLOB($styles; $blob)
Begin SQL
UPDATE arbres SET style = :$blob WHERE id = :$IDarbre;
End SQL
DOM CLOSE XML(This.racineXML)
End if
Function TextualiserStyles($styles : Object)->$result : Text
// renvoyer $styles au format CSS3
$result:=JSON Stringify($styles)
$result:=Replace string($result; ","; ";")
$result:=Replace string($result; Char(Double quote); "")
⇧
[class]_modification_BDD_AG - 01/08/2026 19:21:15
Class extends $arbre
Class constructor($params : Object)
Super($params)
// ----------------------
// MARK:Appel par les Workers
// ----------------------
Function Exécuter()
// on a appelé le WK : ré-initialiser le contexte, au besoin
This.InitProcess()
// le verrouillage des enregistrements par le composants empêche la navigation dans l'arbre (changement de sélection dans la base hôte)
// exemple : clic sur le dernier cadre renseigné de l'arbre (arrière grand-mère maternelle d'un arbre 2-2)
This.OuvrirBDD_Externe()
This.trace.Error:=-15068
Case of
: (Not(OB Is defined(This; "paramsArbre")))
This.trace.ErrorDescription:="la classe n'a pas de 'paramsArbre'"
: (Not(OB Is defined(This.paramsArbre; "functionID")))
This.trace.ErrorDescription:="'functionID' n'est pas définie dans paramsArbre"
: (Not(OB Is defined(This; This.paramsArbre.functionID)))
This.trace.ErrorDescription:="'functionID' n'est pas une function de cette classe"
Else
// c'est ok
This.trace.Error:=0
// lancer
This[This.paramsArbre.functionID]()
End case
This.trace.FixerSuccess()
This.trace.LeverException(This.paramsArbre.optionsMsg)
// ----------------------
// MARK:Création
// ----------------------
Function Construire_AG()
// remarque : la construction se fait dans un process client
var $IDarbre; $options; $ID; $NmaxDescendance; $NmaxAscendance; $IDcadre : Integer
var $params : Object
// Ouvrir / Créer la BDD_AG
This.OuvrirBDD_Externe()
This.ParametrerConstructionArbre()
$IDarbre:=This.paramsArbre.IDarbre
$options:=This.paramsArbre.Options
If (Storage.System.EstExecuteDansHote)
// créer l'architecture logique
// * supposer que tous les cadres doivent être recréés
Begin SQL
START TRANSACTION;
End SQL
Begin SQL
SELECT Nmax_descendance, Nmax_ascendance FROM arbres WHERE arbres.id = :$IDarbre INTO :$NmaxDescendance, :$NmaxAscendance;
UPDATE cadres SET suppressed = TRUE, added = FALSE WHERE arbre = :$IDarbre;
End SQL
// paramètres, on commence par le de-cujus
$params:=New object
$params.DataClassNom:="Personnes"
$params.IDentité:=This.paramsArbre.IDpersonne
This.trace.EnvoyerMessages([msgk_event]; "Construction"; Current method name; "Création de l'arbre "+String($params.IDentité & 0x00FFFFFF)) //; AlertesHôte)
// RAZ des bioData (peuvent avoir été modifiées)
cs.BioData.me.RAZ()
// passer les params
sharedObject(This.paramsArbre; cs.BioData.me.paramsArbre)
// * Décrire l'arborescence de la descendance selon This.paramsArbre
$params.NmaxXscendance:=$NmaxDescendance
$params.Options:=$options ?+ 16
This.CréerArborescence(0; $params; $IDarbre)
// * Décrire l'arborescence de l'ascendance This.paramsArbre
$params.DataClassNom:="Personnes"
$params.IDentité:=This.paramsArbre.IDpersonne
// trouver son cadre (dans l'arbre courant !)
$ID:=$params.IDentité
$IDcadre:=0
Begin SQL
SELECT id FROM cadres WHERE cadres.arbre = :$IDarbre AND cadres.id_objet_BDD = :$ID INTO :$IDcadre;
End SQL
$params.NmaxXscendance:=$NmaxAscendance
$params.Options:=$options ?+ 17
This.CréerArborescence(0; $params; $IDarbre; $IDcadre)
// A ce stade, les cadres non retrouvés ont suppressed = true
// maintenant que tout l'arbre est connu, ajouter les cadres de liens consanguins
This.AjouterElement($IDarbre; 320; -1; -1; -1; "")
// * supprimer les cadres inutiles
This.SupprimerDansBDD($IDarbre; "cadres")
// -- pourrait rester le connecteur -1 -1 ?
Begin SQL
COMMIT TRANSACTION;
End SQL
End if
// à ce stade, les cadres ajoutés ont added = true, init_deploiement = false , deployed = false, init_dessin = false
// les cadres retrouvés ont added = false, init_deploiement = true , deployed = true, init_dessin = true
// les cadres non retrouvés sont supprimés
ASSERT(This.trace.DEBUG_STORE_TAB_BDD_AG(String(Milliseconds)+"-Construction"; This.paramsArbre))
// la suite :
// créer l'architecture physique
This.AppliquerModele_AG()
Function CréerArborescence($rang : Integer; $params : Object; $IDarbre : Integer; $IDcadre : Integer)
var $unions; $membresXcendance : Collection
var $union : cs.Unions
var $deCujus; $membreXcendance : cs.Personnes
var $options; $itemRef : Integer
var $ID; $IDliste; $IDpersonne : Integer
var $entité : Object
This.trace.Initialiser(Current method name)
$options:=$params.Options
// créer l'objet deCujus
$deCujus:=cs.Personnes.new($params.IDentité)
$itemRef:=$deCujus.IDcodé()
If ($options ?? 17)
// ascendance
$unions:=$deCujus.UnionParentale()
Else
// descendance
$unions:=$deCujus.LesUnions().selection
End if
Case of
: ($options ?? 16)
// ajouter le De-Cujus de l'Xscendance
$ID:=This.AjouterElement($IDarbre; 0; $itemRef; 0; -1; $deCujus.IDunique) // attention : la recherche du cadre amont du DeCujus rend 0
// mémoriser les infos du de-cujus
cs.BioData.me.Ajouter($deCujus)
: (Count parameters<4)
This.trace.Error:=-16303
This.trace.ErrorDescription:="il manque le paramètre $IDcadre"
Else
$ID:=$IDcadre
End case
If (($rang+1<=$params.NmaxXscendance) & (This.trace.Error=0))
Case of
: (($unions.length=0) & ($options ?? 1))
// les cadres bidon sont associés à un élément codé 204
// ajouter une union (asc / desc selon) bidon
$IDliste:=This.AjouterElement($IDarbre; 160+(32*Num($options ?? 17)); CodeEnreg(Random; [204]); $ID; 2+Num($options ?? 17); "")
// ajouter un conjoint bidon
If (Not($options ?? 17))
// descendance : ajouter le conjoint
$ID:=This.AjouterElement($IDarbre; 64; CodeEnreg(Random; [204]); $IDliste; 3; "")
End if
// ajouter liens de Xcendance bidon
$IDliste:=This.AjouterElement($IDarbre; 224+(32*Num($options ?? 17)); CodeEnreg(Random; [204]); $IDliste; 2; "")
If ($options ?? 17)
// ascendance : ajouter un parent bidon
$IDpersonne:=This.AjouterElement($IDarbre; 96; CodeEnreg(Random; [204]); $IDliste; 2; "")
Else
// descendance : ajouter un enfant bidon
$IDpersonne:=This.AjouterElement($IDarbre; 32; CodeEnreg(Random; [204]); $IDliste; 2; "")
End if
: ($unions.length>16)
This.trace.Error:=-16317
This.trace.ErrorDescription:="il ne peut pas y avoir plus de 16 unions liées à la personne ID "+String($itemRef & 0x00FFFFFF)
Else
For each ($union; $unions)
// ajouter l'union
$itemRef:=$union.IDcodé()
$IDliste:=This.AjouterElement($IDarbre; 160+(16*Num($unions.indexOf($union)>0))+(32*Num($options ?? 17)); $itemRef; $ID; 2+Num($options ?? 17); $union.IDunique)
// mémoriser les infos de l'union
cs.BioData.me.Ajouter($union)
If (Not($options ?? 17)) // descendance
// ajouter le conjoint
$entité:=$union.getLeConjoint($deCujus.ID)
If ($entité=Null) // personne mariée, mais on ne sait pas avec qui
$itemRef:=CodeEnreg(0; [204])
$ID:=This.AjouterElement($IDarbre; 64; $itemRef; $IDliste; 3; "")
Else
$itemRef:=$entité.IDcodé()
$ID:=This.AjouterElement($IDarbre; 64; $itemRef; $IDliste; 3; $entité.IDunique)
// mémoriser les infos du conjoint
cs.BioData.me.Ajouter($entité)
End if
End if
If ($options ?? 17) // ascendance
$membresXcendance:=$deCujus.LesParents()
Else // descendance
$membresXcendance:=$union.LesEnfants().selection
End if
Case of
: (($membresXcendance.length=0) & ($options ?? 1))
// les cadres bidon sont associés à un élément codé 204
// ajouter liens de Xcendance bidon
$IDliste:=This.AjouterElement($IDarbre; 224+(32*Num($options ?? 17)); CodeEnreg(Random; [204]); $IDliste; 2; "")
// ajouter un enfant bidon
If ($options ?? 17) // ascendance
$IDpersonne:=This.AjouterElement($IDarbre; 96; CodeEnreg(Random; [204]); $IDliste; 2; "")
Else // descendance
$IDpersonne:=This.AjouterElement($IDarbre; 32; CodeEnreg(Random; [204]); $IDliste; 2; "")
End if
: ($membresXcendance.length>16)
This.trace.Error:=-16317
This.trace.ErrorDescription:="il ne peut pas y avoir plus de 16 enfants liés à l'union "+String($union.ID)
Else
// ajouter liens de Xcendance (s'il y a des enfants ou parents)
If ($membresXcendance.length>0)
// l semblerait que $itemRef ne serve pas ! on met le de-cujus
$itemRef:=CodeEnreg($deCujus.ID; [144+(16*Num(Not($options ?? 17)))]) // IDpersonne codé liste d'une union Xcendance
$IDliste:=This.AjouterElement($IDarbre; 224+(32*Num($options ?? 17)); $itemRef; $IDliste; 2; $deCujus.IDunique)
For each ($membreXcendance; $membresXcendance)
// la personne (rappel : enfant ou parent)
// peut être vide (en ascendance) si l'un des parents n'existe pas
If (Not(OB Is empty($membreXcendance)))
$itemRef:=$membreXcendance.IDcodé() // IDpersonne codé [personnes]
// ajouter la personne
If ($options ?? 17) // ascendance
$IDpersonne:=This.AjouterElement($IDarbre; 96+(32*Num($membreXcendance.sexe)); $itemRef; $IDliste; 2+Num($membreXcendance.sexe); $membreXcendance.IDunique) // dépend de [Personnes]sexe
Else // descendance
$IDpersonne:=This.AjouterElement($IDarbre; 32; $itemRef; $IDliste; 1+1+$membresXcendance.indexOf($membreXcendance); $membreXcendance.IDunique)
End if
End if
// mémoriser les infos de l'enfant
cs.BioData.me.Ajouter($membreXcendance)
// continuer l'arbre avec cette personne
$params.DataClassNom:="Personnes"
$params.IDentité:=$membreXcendance.ID
$params.Options:=$options ?- 16
This.CréerArborescence($rang+1; $params; $IDarbre; $IDpersonne)
End for each
End if
End case
End for each
End case
End if
This.trace.LeverException(This.paramsArbre.optionsMsg)
Function AjouterElement($_IDarbre : Integer; $_typeElement : Integer; $_IDobjetBDD : Integer; $_IDcadre : Integer; $_numLogic : Integer; $_UUIDobjet : Text)->$result : Integer
var $typeElement; $IDobjetBDD; $IDcadre; $IDconnexion; $IDcalque; $numLogic; $i : Integer
var $IDarbre; $IDcadreUnion; $IDcadreConsanguin : Integer
var $added : Boolean
var $UUIDobjet : Text
$IDarbre:=$_IDarbre
// *** Pas d’ajout s’il existe déjà un cadre, associé à $3 dont l’origine est connectée à un cadre associé à $4
// chercher une connexion reliant un cadre représentant $3 lié au cadre ID $4 par un connecteur logique 1
$IDconnexion:=-1
// variables pour les requêtes SQL
$IDcadre:=$_IDobjetBDD
$i:=$_IDcadre
Begin SQL
SELECT id, cadre_lie FROM connexions
WHERE connexions.cadre_lie IN (SELECT id FROM cadres WHERE cadres.arbre = :$IDarbre AND cadres.id_objet_BDD = :$IDcadre)
AND connexions.cadre = :$i AND connexions.num_logic_lie = 1 INTO :$IDconnexion, :$IDcadre;
End SQL
// *** si trouvé, ne pas toucher au cadre (l'arbre a déjà été initilialisé)
If ($IDconnexion>0)
Begin SQL
UPDATE cadres SET suppressed = FALSE WHERE cadres.id = :$IDcadre;
End SQL
Else
// *** si pas trouvé , ajouter le cadre
// fixer le calque (0 = il faudra le créer)
$IDcadre:=$_IDcadre
If ($IDcadre=0) // en particulier, le De-Cujus n'a pas de cadre amont
$IDcalque:=0
Else
// -- récupérer le ID calque de $4
Begin SQL
SELECT calque, added FROM cadres WHERE cadres.id = :$IDcadre INTO :$IDcalque, :$added;
End SQL
// si le cadre amont est ajouté, mettre le nouveau dessus. Sinon new calque (voir plus loin)
$IDcalque:=$IDcalque*Num($added)
End if
// ajouter les objets et liens
// variables pour les requêtes SQL
$typeElement:=$_typeElement
$IDobjetBDD:=$_IDobjetBDD
$numLogic:=$_numLogic
$UUIDobjet:=$_UUIDobjet
$IDconnexion:=0
If ($typeElement=320)
// ajouter un cadre 320 entre 2 cadres (autre) union familiale correspondant à la même union
// attention : dans cette version, il y a 2 cadres type 65 par union consanguine
// et garder la descendance de l'union apparaissant la première (Maïthé : cf droit d'ainesse, on affiche dans l'ordre généalogique)
Begin SQL
START TRANSACTION;
End SQL
Begin SQL
DELETE FROM connexions WHERE cadre_lie IN
(SELECT id FROM cadres WHERE cadres.arbre = :$IDarbre AND cadres.type_element = 320);
DELETE FROM cadres WHERE cadres.arbre = :$IDarbre AND cadres.type_element = 320;
End SQL
// chercher les cadres (autre) union familiale liés à un conjoint consanguin (type 65)
ARRAY LONGINT($tabCadres; 0)
ARRAY LONGINT($tabIDunions; 0)
ARRAY LONGINT($tabIDcalques; 0)
Begin SQL
SELECT id, id_objet_BDD, calque FROM cadres WHERE id IN
(SELECT T1.cadre FROM connexions AS T1 LEFT OUTER JOIN cadres as T2 ON T1.cadre_lie = T2.id WHERE cadres.arbre = :$IDarbre AND cadres.type_element = 65)
INTO :$tabCadres, :$tabIDunions, :$tabIDcalques;
End SQL
// trier par ordre d'apparition décroissant
SORT ARRAY($tabCadres; $tabIDunions; $tabIDcalques; <)
For ($i; 1; Size of array($tabIDunions))
$IDcadreUnion:=$tabCadres{$i}
$IDobjetBDD:=$tabIDunions{$i}
$IDcalque:=$tabIDcalques{$i}
// chercher le second cadre relatif à l'union consanguine
// remarque : il peut ne pas exister, si l'un n'est conjoint n'est pas encore marié! (ex NmaxDescendance trop faible)
$IDcadre:=-1
Begin SQL
SELECT id FROM cadres WHERE arbre = :$IDarbre AND id_objet_BDD =:$IDobjetBDD AND NOT(id = :$IDcadreUnion) INTO :$IDcadre;
End SQL
If ($IDcadre=-1)
// l'un des conjoint est d'une génération plus élévée que l'autre et son union avec l'autre n'est pas dans l'arbre (ex NmaxDescendance trop faible)
// dans ce cas, le cadre 320 fait un lien entre le conjoint et l'enfant
// chercher l'IDobjetCodé du conjoint, $IDobjetBDD
$IDcadreUnion:=This.AllerAuCadreConnecte($IDcadreUnion; 3) // même variable pour avoir un code commun avec l'autre cas
Begin SQL
SELECT id_objet_BDD, calque FROM cadres WHERE arbre = :$IDarbre AND id = :$IDcadreUnion INTO :$IDobjetBDD, :$IDcalque;
End SQL
$numLogic:=3
Else
// l'union des 2 conjoints est bien dupliquée dans l'arbre
// dans ce cas, le cadre 320 fait un lien entre les 2 unions
$numLogic:=4
End if
// ajouter le cadre s'il n'existe pas
If (This.AllerAuCadreConnecte($IDcadreUnion; $numLogic)<1)
//-- insérer une union consanguine, type 320
//-- insérer une connexion avec cadre amont ID = union consanguine numLogic = 1, cadre aval ID = premier cadre $IDobjetBDD numLogic = $numLogic
//-- insérer une connexion avec cadre amont ID = union consanguine numLogic = 2, cadre aval ID = second cadre $IDobjetBDD numLogic = $numLogic
Begin SQL
INSERT INTO cadres (arbre, id_objet_BDD, type_element, calque, added, suppressed, init_deploiement, deployed, init_dessin, data) VALUES (:$IDarbre, -1, 320, :$IDcalque, TRUE, FALSE, TRUE, FALSE, FALSE, NULL);
SELECT MAX(id) FROM cadres INTO :$IDcadreConsanguin;
INSERT INTO connexions (cadre, num_logic, cadre_lie, num_logic_lie) VALUES (:$IDcadreUnion, :$numLogic, :$IDcadreConsanguin, 1);
SELECT id FROM cadres WHERE arbre = :$IDarbre AND id_objet_BDD =:$IDobjetBDD AND NOT(id = :$IDcadreUnion) INTO :$IDcadre;
INSERT INTO connexions (cadre, num_logic, cadre_lie, num_logic_lie) VALUES (:$IDcadre, :$numLogic, :$IDcadreConsanguin, 2);
End SQL
ASSERT($IDcadre>-1; "le cadre type 320 n'est pas connecté à 2 cadres consanguins")
// supprimer la descendance (redondante) de $IDcadreUnion
// chercher le cadre de la descendance
$IDcadre:=This.AllerAuCadreConnecte($IDcadreUnion; 2)
This.SupprimerBranche($IDcadre)
End if
End for
Begin SQL
COMMIT TRANSACTION;
End SQL
Else
Begin SQL
-- ajouter une connexion à $4 par $5
INSERT INTO connexions (cadre, num_logic) VALUES (:$IDcadre, :$numLogic);
SELECT MAX(id) FROM connexions INTO :$IDconnexion;
-- ajouter un cadre
INSERT INTO cadres (arbre, id_objet_BDD, uuid_objet_BDD, type_element, added, suppressed, init_deploiement, deployed, init_dessin, data) VALUES (:$IDarbre, :$IDobjetBDD, :$UUIDobjet, :$typeElement, TRUE, FALSE, FALSE, FALSE, FALSE, NULL);
SELECT MAX(id) FROM cadres INTO :$IDcadre;
-- lier à la connexion
UPDATE connexions SET cadre_lie = :$IDcadre, num_logic_lie = 1 WHERE id = :$IDconnexion;
End SQL
ASSERT(cs._Trace.new().DebugerMethode("Déploiement"; Current method name; "Ajout de l'élément ID BDD : "+String($IDobjetBDD >> 24)+"-"+String($IDobjetBDD & 0x00FFFFFF)+" ID BDD_AG : "+String($IDcadre)+" type "+String($typeElement)))
// créer le calque si besoin
If ($IDcalque=0)
// ajouter un calque (remarque : le lie aussi au cadre)
$IDcalque:=This.AjouterCalque($IDarbre; $IDconnexion)
End if
//-- lier le cadre au calque
Begin SQL
UPDATE cadres SET calque = :$IDcalque WHERE id = :$IDcadre;
End SQL
End if
End if
// renvoyer l'ID du cadre trouvé ou ajouté
$result:=$IDcadre
// *** le cadre ajouté peut avoir créé un ou plusieur implexes (cf le cas De-Cujus = 2409 sur 5 générations)
// $3 peut jouer plusieurs rôles : enfant (une fois, dans $IDcadre) ou conjoint (plusieurs fois, dans $tabCadres) : chercher ces rôles
ARRAY LONGINT($tabCadres; 0) // cadres des rôles de conjoint si existent
$typeElement:=$_typeElement
$IDobjetBDD:=$_IDobjetBDD
Case of
: (CodeEnreg($IDobjetBDD)=204)
// pas de consanguinité bidon
: ($typeElement=32)
// on vient d'ajouter ou retrouver une personne (enfant) : $IDcadre
// chercher les rôles de conjoint de $3
Begin SQL
SELECT id FROM cadres WHERE arbre = :$IDarbre AND id_objet_BDD = :$IDobjetBDD AND NOT(type_element = 32) INTO :$tabCadres;
End SQL
: ($typeElement=64)
// on vient d'ajouter ou retrouver un conjoint : $IDcadre
APPEND TO ARRAY($tabCadres; $IDcadre)
// chercher le rôle d'enfant de $3
$IDcadre:=-1
Begin SQL
SELECT id FROM cadres WHERE arbre = :$IDarbre AND id_objet_BDD = :$IDobjetBDD AND (type_element = 0 OR type_element = 32) INTO :$IDcadre;
End SQL
ARRAY LONGINT($tabCadres; Num($IDcadre>0)) // raz si ce conjoint est "normal" (n'est pas un enfant)
End case
If (Size of array($tabCadres)>0)
// il y a des implexes. Pour chacun il faut changer le type 64 en 65
// remarque : à ce stade tous les cadres unions de liens consanguins n'existent pas; les cadres sont créés à la fin des ajouts
For ($i; 1; Size of array($tabCadres))
$IDcadreConsanguin:=$tabCadres{$i}
//-- transformer le conjoint en conjoint consanguin
Begin SQL
UPDATE cadres SET type_element = 65 WHERE cadres.id = :$IDcadreConsanguin;
End SQL
End for
End if
Function AjouterCalque($_IDarbre : Integer; $_IDconnexion : Integer)->$result : Integer
var $IDarbre; $IDcalque; $IDcadre; $IDconnexion; $numOrdre : Integer
// variables pour les requêtes SQL
$IDarbre:=$_IDarbre
$IDconnexion:=$_IDconnexion
$numOrdre:=0
$IDcadre:=0
//-- calculer le n° d'ordre (le premier vaut 0)
//-- ajouter un calque
//-- sélectionner le cadre lié à $2
Begin SQL
SELECT MAX(num_ordre) FROM calques WHERE id IN
(SELECT DISTINCT calque FROM cadres WHERE cadres.arbre = :$IDarbre)
INTO :$numOrdre;
INSERT INTO calques (origine, num_ordre) VALUES(:$IDconnexion, :$numOrdre+1);
SELECT MAX(id) FROM calques INTO :$IDcalque;
SELECT cadre_lie FROM connexions WHERE id = :$IDconnexion INTO :$IDcadre;
End SQL
$result:=$IDcalque
This.AjouterBranche($IDcalque; $IDcadre)
Function AjouterBranche($_IDcalque : Integer; $_IDcadre : Integer)
var $IDcalque; $IDcadre; $i : Integer
// variables pour les requêtes SQL
$IDcalque:=$_IDcalque
$IDcadre:=$_IDcadre
//-- lier le cadre au calque
Begin SQL
UPDATE cadres SET calque = :$IDcalque WHERE id = :$IDcadre;
End SQL
// chercher les cadres liés au cadre courant
ARRAY LONGINT($tabCadres; 0)
Begin SQL
SELECT cadre_lie FROM connexions WHERE cadre = :$IDcadre AND num_logic > 1
INTO :$tabCadres;
End SQL
// affecter le calque aux cadres liés
If (Size of array($tabCadres)>0) // il y a des cadres connectés
For ($i; 1; Size of array($tabCadres))
This.AjouterBranche($_IDcalque; $tabCadres{$i})
End for
End if
Function SupprimerBranche($_IDcadre : Integer)
var $IDcadre; $i : Integer
// variables pour les requêtes SQL
$IDcadre:=$_IDcadre
If ($IDcadre>0)
Begin SQL
UPDATE cadres SET suppressed = TRUE WHERE id = :$IDcadre;
End SQL
// chercher les cadres liés au cadre courant
ARRAY LONGINT($tabCadres; 0)
Begin SQL
SELECT cadre_lie FROM connexions WHERE cadre = :$IDcadre AND num_logic > 1
INTO :$tabCadres;
End SQL
// supprimer ces cadres
If (Size of array($tabCadres)>0) // il y a des cadres connectés
For ($i; 1; Size of array($tabCadres))
This.SupprimerBranche($tabCadres{$i})
End for
End if
End if
Function SupprimerDansBDD($dansIDarbre : Integer; $quoi : Text)
// supprimer dans la BDD $1 les enregistrements $2
var $IDarbre : Integer
Case of
: ($quoi="cadres")
// retyper pour SQL
$IDarbre:=$dansIDarbre
// Doc : lister toutes les lignes du tableau T1 (table de gauche)
// et afficher les données associées du tableau T2
// s’il y a une correspondance entre id de T2 et cadre de T1.
// s’il n’y a pas de correspondance, l’enregistrement de T2 sera affiché et les colonnes de T1 vaudront toutes NULL.
// -- supprimer les connexions des cadres à supprimer
// -- supprimer les cadres
// -- supprimer les calques sans lien avec des cadres
Begin SQL
START TRANSACTION;
DELETE FROM connexions WHERE id IN
(SELECT T1.id FROM connexions as T1 LEFT OUTER JOIN cadres as T2 ON T1.cadre = T2.id WHERE cadres.arbre = :$IDarbre AND cadres.suppressed = TRUE);
DELETE FROM connexions WHERE id IN
(SELECT T1.id FROM connexions as T1 LEFT OUTER JOIN cadres as T2 ON T1.cadre_lie = T2.id WHERE cadres.arbre = :$IDarbre AND cadres.suppressed = TRUE);
DELETE FROM cadres WHERE cadres.arbre = :$IDarbre AND cadres.suppressed = TRUE;
DELETE FROM calques WHERE id IN (SELECT id FROM calques WHERE NOT EXISTS (SELECT calque FROM cadres WHERE cadres.calque = calques.id));
COMMIT TRANSACTION;
End SQL
Else
End case
Function AllerAuCadreConnecte($_IDcadre : Integer; $_numLogic : Integer)->$result : Integer
var $IDcadre; $numLogic : Integer
$IDcadre:=$_IDcadre
$numLogic:=$_numLogic
ARRAY LONGINT($tabCadres; 0)
Begin SQL
SELECT cadre_lie FROM connexions
WHERE connexions.cadre = :$IDcadre AND connexions.num_logic = :$numLogic
INTO :$tabCadres;
End SQL
ASSERT(Size of array($tabCadres)<2; "plus d'un cadre lié au connecteur num "+String($2)+" du cadre ID "+String($1))
Case of
: (Size of array($tabCadres)=0)
$result:=0
: (Size of array($tabCadres)=1)
$result:=$tabCadres{1}
Else
$result:=-1
End case
Function AppliquerModele_AG()
// début transaction
Begin SQL
START TRANSACTION;
End SQL
This.trace.EnvoyerMessages(This.paramsArbre.optionsMsg; "Construction"; Current method name; "Fixer le modèle")
This.InitialiserModeleArbre()
// appliquer le modèle de représentation
This.ParametrerModeleArbre()
// renseigner les calques
This.ParametrerModeleCalque()
// à ce stade, les cadres ajoutés ont added = false/true, init_deploiement = false , deployed = false, init_dessin = false
// renseigner les cadres non initialisés
This.ParametrerModeleCadre()
// fin transaction
Begin SQL
COMMIT TRANSACTION;
End SQL
// à ce stade, les cadres ajoutés ont added = true, init_deploiement = true , deployed = false, init_dessin = true
ASSERT(This.trace.DEBUG_STORE_TAB_BDD_AG(String(Milliseconds)+"-Calquage"; This.paramsArbre))
// lancer le déploiement
This.Deployer_AG()
// ----------------------
// MARK:Déploiement
// ----------------------
Function Deployer_AG()
var $IDarbre : Integer
var $tablesBDD_AG : Object
// variables pour les requêtes SQL
$IDarbre:=This.paramsArbre.IDarbre
// init déploiement
This.ParametrerDeploiementArbre()
// attention : à partir d'ici les options de l'arbre doivent être lues dans la BDD_AG
// passer au process le contenu des tables 'cadres', 'connexions' et 'calques' de la BDD_AG de l'arbre courant
// lire les données de la BDD_AG : 3 tableaux typés data et du nombre max de data (=> des sous tableaux vides mais code générique)
ARRAY LONGINT(champINT; 23; 0)
ARRAY REAL(champREAL; 23; 0)
ARRAY BOOLEAN(champBOOL; 23; 0)
// les indices de tableaux sont des constantes du thème TablesBDD_AG
// tous les cadres de l'arbre
Begin SQL
SELECT id, type_element, calque, largeur, hauteur, gauche, haut, init_deploiement, deployed FROM cadres WHERE cadres.arbre = :$IDarbre INTO :[champINT{1}], :[champINT{2}], :[champINT{3}], :[champREAL{4}], :[champREAL{5}], :[champREAL{6}], :[champREAL{7}], :[champBOOL{8}], :[champBOOL{9}];
End SQL
// tous les calques de l'arbre
Begin SQL
SELECT id, origine, num_ordre, visible FROM calques WHERE id IN (SELECT DISTINCT calque FROM cadres WHERE cadres.arbre = :$IDarbre) INTO :[champINT{20}], :[champINT{21}], :[champINT{22}], :[champBOOL{23}];
End SQL
// toutes les connexions des cadres de l'arbre ET toutes les connexions vers le cadre 0 (= départ du calque de fond). S'il y a plusieurs arbres dans la BDD_AG on les récupère tous !
Begin SQL
SELECT id, cadre, num_logic, cadre_lie, num_logic_lie, direction, x_reduit, y_reduit, x_reduit_lie, y_reduit_lie FROM connexions WHERE cadre IN (SELECT id FROM cadres WHERE cadres.arbre = :$IDarbre) OR connexions.cadre = 0 INTO :[champINT{10}], :[champINT{11}], :[champINT{12}], :[champINT{13}], :[champINT{14}], :[champINT{15}],:[champREAL{16}], :[champREAL{17}], :[champREAL{18}], :[champREAL{19}];
End SQL
If (Size of array(champINT{1})>0)
// on a des cadres à dessiner
$tablesBDD_AG:=This.LireTableauxBDD_AG()
// lancer le déploiement
This.paramsArbre.EtatProcessus.WorkerAppelant:=Current process name
CALL WORKER("WK_DeployerArbre"; Formula from string("cs._deploiement.new($1).Deployer_AG($2)"); This.paramsArbre; $tablesBDD_AG)
Else
// rien à dessiner
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; "Déploiement"; Current method name; "Arbre vide"; New object("nomProcess"; Current process name; "numProcess"; Current process))
This.TerminerDéploiement_AG()
End if
Function AppliquerDéploiement_AG()
// à partir de v4.5, le déploiement a été fait dans un process préemptif dédié
// retour ici
var $IDarbre; $i; $ID : Integer
var $varREAL_1; $varREAL_2; $varREAL_3; $varREAL_4 : Real
var $varBOOL_1 : Boolean
var $tablesBDD_AG : Object
// variables pour les requêtes SQL
$IDarbre:=This.paramsArbre.IDarbre
CALL WORKER(Worker Services; Formula from string(Formule_EnvoyerMessageAG); [msgk_event]; "Déploiement"; Current method name; "Mise à jour BDD"; New object("nomProcess"; Current process name; "numProcess"; Current process))
$tablesBDD_AG:=This.paramsArbre.tablesBDD_AG
// mettre à jour la BDD_AG avec les données $tablesBDD_AG
// * relire les tableaux de données
ARRAY LONGINT(champINT; 23; 0)
ARRAY REAL(champREAL; 23; 0)
ARRAY BOOLEAN(champBOOL; 23; 0)
This.EcrireTableauxBDD_AG($tablesBDD_AG)
Begin SQL
START TRANSACTION;
End SQL
// mettre à jour la BDD_AG
// tous les cadres de l'arbre
For ($i; 1; Size of array(BDD_AG{cadres_ID}->))
$ID:=BDD_AG{cadres_ID}->{$i}
$varREAL_1:=BDD_AG{cadres_largeur}->{$i}
$varREAL_2:=BDD_AG{cadres_hauteur}->{$i}
$varREAL_3:=BDD_AG{cadres_gauche}->{$i}
$varREAL_4:=BDD_AG{cadres_haut}->{$i}
$varBOOL_1:=BDD_AG{cadres_deployed}->{$i}
Begin SQL
UPDATE cadres SET largeur = :$varREAL_1, hauteur = :$varREAL_2, gauche = :$varREAL_3, haut = :$varREAL_4, deployed = :$varBOOL_1 WHERE cadres.id = :$ID;
End SQL
End for
// toutes les connexions des cadres de l'arbre
For ($i; 1; Size of array(BDD_AG{connexions_ID}->))
$ID:=BDD_AG{connexions_ID}->{$i}
$varREAL_1:=BDD_AG{connexions_x_reduit}->{$i}
$varREAL_2:=BDD_AG{connexions_y_reduit}->{$i}
$varREAL_3:=BDD_AG{connexions_x_reduit_lie}->{$i}
$varREAL_4:=BDD_AG{connexions_y_reduit_lie}->{$i}
Begin SQL
UPDATE connexions SET x_reduit = :$varREAL_1, y_reduit = :$varREAL_2, x_reduit_lie = :$varREAL_3, y_reduit_lie = :$varREAL_4 WHERE connexions.id = :$ID;
End SQL
End for
//-- nettoyer les attributs added
Begin SQL
UPDATE cadres SET added = FALSE WHERE cadres.arbre = :$IDarbre;
End SQL
Begin SQL
COMMIT TRANSACTION;
End SQL
// à ce stade, tous les cadres ont added = false, init_deploiement = true , deployed = true
// rmk : init_dessin dépend les infos disponibles dans le modèle
ASSERT(This.trace.DEBUG_STORE_TAB_BDD_AG(String(Milliseconds)+"-Déploiement"; This.paramsArbre))
This.TerminerDéploiement_AG()
Function TerminerDéploiement_AG()
// ici arrive la commande 'Terminer Déploiement AG' ou celles ne portant pas sur la modification
// passer à la suite
var $IDarbre : Integer
// variables pour les requêtes SQL
$IDarbre:=This.paramsArbre.IDarbre
Begin SQL
START TRANSACTION;
End SQL
// -- renseigner les éventuels problèmes d'initialisation
ARRAY LONGINT($tabCadres; 0)
Begin SQL
SELECT id FROM cadres WHERE cadres.arbre = :$IDarbre AND cadres.init_deploiement = FALSE INTO :$tabCadres;
End SQL
If (Size of array($tabCadres)>0)
This.trace.EnvoyerMessages([msgk_event]; "Déploiement"; Current method name; "Retour de déploiement : "+String(Size of array($tabCadres))+" cadres non initialisés pour le déploiement")
End if
Begin SQL
SELECT id FROM cadres WHERE cadres.arbre = :$IDarbre AND cadres.deployed = FALSE INTO :$tabCadres;
End SQL
If (Size of array($tabCadres)>0)
This.trace.EnvoyerMessages([msgk_event]; "Déploiement"; Current method name; "Retour de déploiement : "+String(Size of array($tabCadres))+" cadres non déployés")
End if
Begin SQL
SELECT id FROM cadres WHERE cadres.arbre = :$IDarbre AND cadres.init_dessin = FALSE INTO :$tabCadres;
End SQL
If (Size of array($tabCadres)>0)
This.trace.EnvoyerMessages([msgk_event]; "Déploiement"; Current method name; "Retour de déploiement : "+String(Size of array($tabCadres))+" cadres non initialisés pour le dessin")
End if
Begin SQL
COMMIT TRANSACTION;
End SQL
If ((Not(OB Is defined(This.paramsArbre; "numFenetreAppelante"))) & (Not(OB Is defined(This.paramsArbre; "numProcessAppelant"))) & (Not(OB Is defined(This.paramsArbre; "finDeTâche"))))
// rien, on veut seulement modifier la BDD_AG
Else
// lancer le dessin
cs.$arbre.new(This.paramsArbre).Dessiner_AG_dansVariable()
End if
// ----------------------
// MARK:Paramétrages
// ----------------------
Function ParametrerConstructionArbre()
// initialiser les paramètres nécessaires à la construction
var $ID; $IDarbre; $data : Integer
var $dataTexte : Text
var $fichier : 4D.File
This.trace.Initialiser(Current method name)
Begin SQL
START TRANSACTION;
End SQL
// variables pour les requêtes SQL
$ID:=0
$IDarbre:=This.paramsArbre.IDarbre
// est ce que l'arbre existe en BDD_AG?
Begin SQL
SELECT arbres.id FROM arbres WHERE id = :$IDarbre INTO :$ID;
End SQL
If ($ID=0) // l'arbre est à créer :
// il faut un ID d'arbre
This.trace.ErrorDescription:="l'ID du De-Cujus n'est pas défini"
If (OB Is defined(This.paramsArbre; "IDarbre"))
This.trace.ErrorDescription:="l'ID de l'arbre est invalide"
$ID:=This.paramsArbre.IDarbre
If ($ID>0)
// il faut un modèle : affecter le modèle Normal
This.trace.ErrorDescription:="fichier recherché <Normal.xml>"
$fichier:=This.getDossierModelesAG().file("Normal.xml")
$dataTexte:=""
Case of
: (Not($fichier.exists))
This.trace.Error:=-16307
: (Not(cs.xSDK.XML.me.LireFichier($fichier; ->$dataTexte).success))
This.trace.Error:=-16307
Else
Begin SQL
INSERT INTO arbres (id, Nmax_ascendance, Nmax_descendance, modele) VALUES (:$ID, 0, 1, :$dataTexte);
End SQL
End case
Else
This.trace.Error:=-16317
End if
End if
End if
This.trace.LeverException(This.paramsArbre.optionsMsg)
If ($ID>0)
// la description de l'arborescence mettra à jour l'arbre avec ces niveaux (à la place des anciens s'ils existent)
// la table [arbres] n'a qu'un enregistrement
If (This.paramsArbre.NmaxAscendance#Null) // mettre à jour
$data:=This.paramsArbre.NmaxAscendance
Begin SQL
UPDATE arbres SET Nmax_ascendance = :$data WHERE id = :$ID;
End SQL
End if
If (This.paramsArbre.NmaxDescendance#Null) // mettre à jour
$data:=This.paramsArbre.NmaxDescendance
Begin SQL
UPDATE arbres SET Nmax_descendance = :$data WHERE id = :$ID;
End SQL
End if
End if
Begin SQL
COMMIT TRANSACTION;
End SQL
Function InitialiserModeleArbre()
// initialiser le modèle nécessaire au déploiement
// le déploiement / dessin utilisera ce modèle (à la place de l'ancien s'il existe)
var $IDarbre : Integer
var $fichier : 4D.File
var $dataTexte : Text
// utiliser le modèle de représentation demandé
If (This.paramsArbre.Modele#Null)
$fichier:=This.getDossierModelesAG().file(This.paramsArbre.Modele)
If ($fichier.exists)
cs.xSDK.XML.me.LireFichier($fichier; ->$dataTexte)
//-- renseigner les données du modèle
// variables pour les requêtes SQL
$IDarbre:=This.paramsArbre.IDarbre
Begin SQL
START TRANSACTION;
UPDATE arbres SET modele = :$dataTexte WHERE id = :$IDarbre;
COMMIT TRANSACTION;
End SQL
Else
This.trace.Initialiser(Current method name)
This.trace.Error:=-16307
This.trace.ErrorDescription:="modèle dans les paramètres de l'arbre <"+This.paramsArbre.Modele+">"
This.trace.LeverException(This.paramsArbre.optionsMsg)
End if
End if
Function ParametrerModeleArbre()
// initialiser les paramètres arbre
// le déploiement / dessin utilisera ce modèle (à la place de l'ancien s'il existe)
var $IDarbre : Integer
// ici la transaction existe
// variables pour les requêtes SQL
$IDarbre:=This.paramsArbre.IDarbre
//-- forcer la mise à jour de tout l'arbre
Begin SQL
START TRANSACTION;
UPDATE cadres SET init_deploiement = FALSE, deployed = FALSE, gauche = 0, haut = 0, init_dessin = FALSE WHERE cadres.arbre = :$IDarbre;
COMMIT TRANSACTION;
End SQL
Function ParametrerModeleCalque()
// appliquer à partir du modèle de l'arbre les styles de tous les calques
// mettre les erreurs dans l'état processus pour retour vers l'hôte
var $dataTexte; $racineXML : Text
var $ajout : Boolean
var $IDarbre; $IDcalque; $options; $Error; $i; $ID : Integer
var $style : Object
var $blob : Blob
// ici la transaction existe
// variables pour les requêtes SQL
$IDarbre:=This.paramsArbre.IDarbre
// commencer par traiter la préférence utilisateur (affichage des ajouts)
$IDcalque:=0
//-- récupérer l'ID calque et l'ajout du De-Cujus
//-- récupérer le modèle
Begin SQL
SELECT added, calque FROM cadres WHERE arbre = :$IDarbre AND type_element = 0 INTO :$ajout, :$IDcalque;
SELECT modele FROM arbres WHERE id = :$IDarbre INTO :$dataTexte;
End SQL
// Chercher ces calques
ARRAY LONGINT($tabCalques; 0)
Begin SQL
SELECT DISTINCT calques.id FROM calques LEFT OUTER JOIN cadres ON calques.id=cadres.calque WHERE cadres.arbre = :$IDarbre AND cadres.added = TRUE
INTO :$tabCalques;
-- récupérer les options de l'arbre
SELECT options FROM arbres WHERE arbres.id = :$IDarbre INTO :$options;
End SQL
If ($ajout) // le De-Cujus a été ajouté
// Dans ce cas tous les cadres sont sur le calque 1 : ne rien faire
Else
// Dans ce cas, la visualisation des calques associés à des cadres ajoutés dépend des user options
If ($options ?? 0)
// garder les calques des cadres ajoutés (auront un style différent du calque de fond)
Else
// supprimer ces calques
If (Size of array($tabCalques)>0)
//-- placer tous les cadres sur le calque $IDcalque (du De-Cujus)
//-- re-initialiser le déploiement
Begin SQL
START TRANSACTION;
UPDATE cadres SET calque = :$IDcalque, init_deploiement = FALSE, deployed = FALSE, gauche = 0, haut = 0, init_dessin = FALSE WHERE cadres.arbre = :$IDarbre;
COMMIT TRANSACTION;
End SQL
//-- supprimer les calques des cadres ajoutés (les cadres auront le style du calque fond
For ($i; 1; Size of array($tabCalques))
$ID:=$tabCalques{$i}
Begin SQL
DELETE FROM calques WHERE calques.id = :$ID;
End SQL
End for
End if
End if
// à ce stade, il y a un calque de fond pour tous les cadres ($options ?? 0)
// ou bien, il y a un calque pour les cadres non ajoutés et un calque pour chaque branche ajoutée
End if
// renseigner les styles de calque
$racineXML:=DOM Parse XML variable($dataTexte)
$Error:=-16308*Num(ok=0)
If ($Error=0)
// * lire les styles du calque de fond
$style:=This.LireStyleDuModele($racineXML; "/modele/calque")
// * écrire les attributs du calque de fond
VARIABLE TO BLOB($style; $blob)
Begin SQL
START TRANSACTION;
UPDATE calques SET visible = TRUE, style = :$blob WHERE id = :$IDcalque;
COMMIT TRANSACTION;
End SQL
// les autres calques
// * lire les styles du calque
$style:=This.LireStyleDuModele($racineXML; "/modele/calqueDesAjouts")
// * écrire les attributs des calques autres que le fond
VARIABLE TO BLOB($style; $blob)
Begin SQL
START TRANSACTION;
UPDATE calques SET visible = TRUE, style = :$blob WHERE id IN (SELECT calques.id FROM calques WHERE id <> :$IDcalque);
COMMIT TRANSACTION;
End SQL
DOM CLOSE XML($RacineXML)
Else
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "absence de styles de calque")
End if
Function ParametrerModeleCadre()
// $1 : paramètres arbre
// appliquer le modèle lu dans [arbres] à tous les cadres non initialisés de l'arbre
// mettre les erreurs dans l'état processus pour retour vers l'hôte
var $dataTexte; $racineXML; $Xpath; $elementXML; $enfantXML; $propriété : Text
var $IDarbre; $i; $j; $element; $numLogic; $Error : Integer
var $largeur; $hauteur; $Xposition; $Yposition; $orientation; $rotation : Real
var $data : Object
var $blob : Blob
// ici la transaction existe
// variables pour les requêtes SQL
$IDarbre:=This.paramsArbre.IDarbre
// récupérer le modèle
Begin SQL
SELECT modele FROM arbres WHERE id = :$IDarbre INTO :$dataTexte;
End SQL
// pour debug
//TEXTE VERS DOCUMENT("FixerParamsCadre.xml"; $dataTexte)
// commencer par les connecteurs
ARRAY LONGINT($tabTypeElement; 0)
ARRAY LONGINT($tabNumLogic; 0)
//-- rechercher tous les types de connecteurs des cadres amont non initialisés
// la jonction peut renvoyer num_logic = 0 type_element > 0 : cas où le connecteur est lié à un cadre aval
// on les élimine par HAVING
// la seconde requete cherche les connecteurs des cadres aval
Begin SQL
SELECT DISTINCT cadres.type_element, connexions.num_logic
FROM cadres
FULL OUTER JOIN connexions ON connexions.cadre = cadres.id
WHERE cadres.arbre = :$IDarbre AND cadres.init_deploiement = FALSE
HAVING connexions.num_logic > 0
INTO :$tabTypeElement, :$tabNumLogic;
End SQL
//-- rechercher tous les types de connecteurs des cadres aval non initialisés
ARRAY LONGINT($tabTypeElement_Aval; 0)
ARRAY LONGINT($tabNumLogic_Aval; 0)
Begin SQL
SELECT DISTINCT cadres.type_element, connexions.num_logic_lie
FROM cadres
FULL OUTER JOIN connexions ON connexions.cadre_lie = cadres.id
WHERE cadres.arbre = :$IDarbre AND cadres.init_deploiement = FALSE
HAVING connexions.num_logic_lie > 0
INTO :$tabTypeElement_Aval, :$tabNumLogic_Aval;
End SQL
// pas glop : sommer les tableaux à la main
For ($i; 1; Size of array($tabTypeElement_Aval))
APPEND TO ARRAY($tabTypeElement; $tabTypeElement_Aval{$i})
APPEND TO ARRAY($tabNumLogic; $tabNumLogic_Aval{$i})
End for
$racineXML:=DOM Parse XML variable($dataTexte)
$Error:=-16308*Num(ok=0)
If ($Error#0)
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "absence de styles de cadre")
End if
// * initialiser les connecteurs de cadre
If ((Size of array($tabTypeElement)>0) & ($Error=0))
For ($i; 1; Size of array($tabTypeElement))
$elementXML:=DOM Find XML element by ID($racineXML; String($tabTypeElement{$i}))
If (ok=1)
// lire les infos du connecteur numLogic $tabNumLogic{$i} de l'élément $tabTypeElement{$i})
$Xpath:="deploiement/connecteur_"+String($tabNumLogic{$i})
$enfantXML:=DOM Find XML element($elementXML; $Xpath+"/X_reduit")
If (ok=1)
DOM GET XML ELEMENT VALUE($enfantXML; $Xposition)
Else
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "Modèle AG courant : <X_reduit> du connecteur "+String($tabNumLogic{$i})+" de l'élément type "+String($tabTypeElement{$i})+" n'est pas renseigné")
End if
$enfantXML:=DOM Find XML element($elementXML; $Xpath+"/Y_reduit")
If (ok=1)
DOM GET XML ELEMENT VALUE($enfantXML; $Yposition)
Else
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "Modèle AG courant : <Y_reduit> du connecteur "+String($tabNumLogic{$i})+" de l'élément type "+String($tabTypeElement{$i})+" n'est pas renseigné")
End if
$enfantXML:=DOM Find XML element($elementXML; $Xpath+"/orientation")
If (ok=1)
DOM GET XML ELEMENT VALUE($enfantXML; $orientation)
Else
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "Modèle AG courant : <orientation> du connecteur "+String($tabNumLogic{$i})+" de l'élément type "+String($tabTypeElement{$i})+" n'est pas renseigné")
End if
// écrire les infos du connecteur numLogic $tabNumLogic{$i} des cadres de type $tabTypeElement{$i})
// écrire les infos du connecteur numLogic_lie $tabNumLogic{$i} des cadres de type $tabTypeElement{$i})
$element:=$tabTypeElement{$i} // bug 4D ?? ici la compilation ne veut pas des éléments de tableaux
$numLogic:=$tabNumLogic{$i}
Begin SQL
UPDATE connexions SET x_reduit = :$Xposition, y_reduit = :$Yposition, direction = :$orientation WHERE id IN
(SELECT connexions.id FROM connexions
FULL OUTER JOIN cadres ON connexions.cadre = cadres.id
WHERE connexions.num_logic = :$numLogic AND cadres.arbre = :$IDarbre AND cadres.init_deploiement = FALSE AND cadres.type_element = :$element);
UPDATE connexions SET x_reduit_lie = :$Xposition, y_reduit_lie = :$Yposition, direction = :$orientation WHERE id IN
(SELECT connexions.id FROM connexions
FULL OUTER JOIN cadres ON connexions.cadre_lie = cadres.id
WHERE connexions.num_logic_lie = :$numLogic AND cadres.arbre = :$IDarbre AND cadres.init_deploiement = FALSE AND cadres.type_element = :$element);
End SQL
Else
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "Modèle AG courant : les connecteurs de l'élément type "+String($tabTypeElement{$i})+" ne sont pas renseignés")
End if
End for
// si tous les connecteurs nécessaires sont renseignés, passer aux cadres et signaler la fin de l'init déploiement
// conception : faire 2 boucles pour gérer séparément les erreurs (=> possibilité de déployer des cadres sans informations)
// chercher les cadres non initialisés
Begin SQL
SELECT DISTINCT cadres.type_element FROM cadres
WHERE cadres.init_deploiement = FALSE
INTO :$tabTypeElement;
End SQL
// initialiser les dimensions des cadres et valider l'init déploiement
For ($i; 1; Size of array($tabTypeElement))
$elementXML:=DOM Find XML element by ID($racineXML; String($tabTypeElement{$i}))
If (ok=1)
// * lire les dimensions
$enfantXML:=DOM Find XML element($elementXML; "deploiement/largeur")
If (ok=1)
DOM GET XML ELEMENT VALUE($enfantXML; $largeur)
Else
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "Modèle AG courant : la largeur de l'élément type "+String($tabTypeElement{$i})+" n'est pas renseignée")
End if
$enfantXML:=DOM Find XML element($elementXML; "deploiement/hauteur")
If (ok=1)
DOM GET XML ELEMENT VALUE($enfantXML; $hauteur)
Else
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "Modèle AG courant : la hauteur de l'élément type "+String($tabTypeElement{$i})+" n'est pas renseignée")
End if
$enfantXML:=DOM Find XML element($elementXML; "deploiement/rotation")
If (ok=1)
DOM GET XML ELEMENT VALUE($enfantXML; $rotation)
Else
$rotation:=0
End if
// écrire les dimensions des cadres de type $tabTypeElement{$i}) non initialisés et valider l'init déploiement
// v9.5.5 gestion de la rotation du cadre
$element:=$tabTypeElement{$i}
If (($rotation=90) | ($rotation=-90))
Begin SQL
UPDATE cadres SET largeur = :$hauteur, hauteur = :$largeur, rotation = :$rotation, init_deploiement = TRUE WHERE id IN
(SELECT cadres.id FROM cadres
WHERE cadres.arbre = :$IDarbre AND cadres.init_deploiement = FALSE AND cadres.type_element = :$element);
End SQL
Else
Begin SQL
UPDATE cadres SET largeur = :$largeur, hauteur = :$hauteur, rotation = :$rotation, init_deploiement = TRUE WHERE id IN
(SELECT cadres.id FROM cadres
WHERE cadres.arbre = :$IDarbre AND cadres.init_deploiement = FALSE AND cadres.type_element = :$element);
End SQL
End if
Else
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "Modèle AG courant : les données de déploiement de l'élément type "+String($tabTypeElement{$i})+" ne sont pas renseignées")
End if
End for
// initialiser les informations à afficher et valider l'init dessin
For ($i; 1; Size of array($tabTypeElement))
OB REMOVE($data; "informations")
OB REMOVE($data; "styles")
$elementXML:=DOM Find XML element by ID($racineXML; String($tabTypeElement{$i}))
If (ok=1)
// * lire les informations à afficher
ARRAY TEXT($informationsList; 0)
$enfantXML:=DOM Find XML element($elementXML; "informationsList/information"; $informationsList)
// * vérifier que des informations existent
If ((ok=1) & (Size of array($informationsList)>0))
ARRAY OBJECT($informations; Size of array($informationsList))
// oops : OB FIXER ne copie pas la valeur de la variable, mais crée un lien => il faut une variable styles par information
// NON utiliser OB copier !!!!!
For ($j; 1; Size of array($informationsList))
// * lister toutes les données possibles d'une information
$informations{$j}:=New object
$informations{$j}.typeInfo:=-1
$informations{$j}.orientation:=-1
$informations{$j}.positionX:=-1
$informations{$j}.positionY:=-1
$informations{$j}.Options:=-1
$informations{$j}.FormatDate:=-1
$informations{$j}.FormatHeure:=-1
// essayer de lire ces données
For each ($propriété; OB Keys($informations{$j}))
// * lire la datum atchoum !
$enfantXML:=DOM Find XML element($informationsList{$j}; $propriété)
If (ok=1)
DOM GET XML ELEMENT VALUE($enfantXML; $dataTexte)
OB SET($informations{$j}; $propriété; Num($dataTexte)) // que des données de type entier
End if
End for each
End for
OB SET ARRAY($data; "informations"; $informations)
// écrire les informations des cadres de type $tabTypeElement{$i}) non initialisés et valider l'init dessin
$element:=$tabTypeElement{$i}
SET BLOB SIZE($blob; 0)
VARIABLE TO BLOB($data; $blob)
Begin SQL
UPDATE cadres SET data = :$blob, init_dessin = TRUE WHERE id IN
(SELECT cadres.id FROM cadres
WHERE cadres.arbre = :$IDarbre AND cadres.init_dessin = FALSE AND cadres.type_element = :$element);
End SQL
Else
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "Modèle AG : l'élément "+String($tabTypeElement{$i})+" n'a pas d'informations à afficher")
End if
Else
This.trace.EnvoyerMessages([msgk_event]; "Paramétrage"; Current method name; "Modèle AG courant : les données de dessin de l'élément type "+String($tabTypeElement{$i})+" ne sont pas renseignées")
End if
End for
DOM CLOSE XML($RacineXML)
End if
Function ParametrerDeploiementArbre()
// les options de représentation de l'arbre
var $IDarbre; $options : Integer
// variables pour les requêtes SQL
$IDarbre:=This.paramsArbre.IDarbre
$options:=0 // pas d'options
If (This.paramsArbre.Options#Null)
// mettre à jour
$options:=This.paramsArbre.Options
Begin SQL
START TRANSACTION;
UPDATE arbres SET options = :$options WHERE id = :$IDarbre;
COMMIT TRANSACTION;
End SQL
End if
⇧
[class]UnionsSelect - 29/05/2025 12:48:33
property selectionRecherche : Collection
Class extends _ARB_DataStore
Class constructor($requête : Variant)
Super("UnionsSelect"; $requête)
This.selection:=Null
This.length:=0
Function TrierSelectionRecherche($triParConjoint1 : Boolean)
If ($triParConjoint1)
// trier par le nom / prénom du premier conjoint
This.selectionRecherche:=This.selectionRecherche.orderBy("itemNom asc")
Else
// trier par le nom / prénom du secon conjoint
This.selectionRecherche:=This.selectionRecherche.orderByMethod(Formula(Compare strings(Substring($triParConjoint1.itemNom.value; Position(" & "; $triParConjoint1.itemNom.value)+3); Substring($triParConjoint1.itemNom.value2; Position(" & "; $triParConjoint1.itemNom.value2)+3))<0))
End if
⇧
[class]Events - 29/05/2025 13:04:35
property trace : cs._Trace
property leLieu : cs.Lieux
Class extends _ARB_DataStore
Class constructor($IDentité : Variant)
// initialiser l'objet avec les données de l'entité $IDentité de la BDD
// rappel : l'event est genré dynamiquement (voir le getEvent() de la classe Personne)
Super("Events"; $IDentité)
This.trace:=cs._Trace.me
// ----------------------
//MARK:Wrappers
// ----------------------
Function Libellé($formats : Object)->$libellé : Text
$libellé:=This.fct.Libellé($formats)
Function FormaterDate($formats : Object)->$result : Text
$result:=This.fct.FormaterDate($formats)
Function FormaterHeure($formats : Object)->$result : Text
$result:=This.fct.FormaterHeure($formats)
Function parent()->$result : Object
// chercher le parent
$result:=This.fct.parent()
// ----------------------
//MARK:Selection
// ----------------------
Function LesProtagonistes()->$result : cs.PersonnesSelect
var $c : Collection
$c:=This.fct.LesProtagonistes()
$result:=cs.PersonnesSelect.new($c)
$result.Créer()
// trier par sexe
$result.selection.orderBy("sexe asc")
Function LeLieu()->$result : cs.Lieux
$result:=cs.Lieux.new(This.leLieu.ID)
⇧
[class]Regions - 13/01/2025 12:51:30
Class extends _ARB_DataStore
Class constructor($IDentité : Variant)
// initialiser l'objet avec les données de l'entité $IDentité de la BDD
Super("Regions"; $IDentité)
⇧
[ ]AfficherArbre - 18/02/2026 12:39:52
// Form peut être null (ex à l'ouverture du formulaire)
If (Not(Form=Null))
Form.TraiterFORMevent()
End if
⇧
[ ]Saisie - 01/02/2026 13:04:42
Pas de code
⇧
[ ]Test Visualiser Arbre - 03/02/2026 11:51:01
var $Error : Integer
var $RefMenu; $ligneMenu : Text
var $result : Object
Case of
: (Form event code=On Load)
// initialiser l'arbre. Dans ce contexte paramsArbre est défini
// lancer, dans le contexte du sous formulaire, l'affichage de l'arbre
$Error:=0
Form.arbre:=cs.$arbre.new(Form.paramsArbre; Form)
// lancer la construction
$result:=Form.arbre.Afficher_AG(OB Copy(Form.paramsArbre))
: (Form event code=On Clicked)
Case of
: ((Right click) | (Contextual click)) // Clic droit ou Control+clic
$RefMenu:=Create menu
APPEND MENU ITEM($RefMenu; "Menu 1 Form process debut"; *)
SET MENU ITEM PARAMETER($RefMenu; -1; "toto 1")
APPEND MENU ITEM($RefMenu; "Menu 2 Form process fin"; *)
SET MENU ITEM PARAMETER($RefMenu; -1; "toto 2")
Form.arbre.menu.FixerMenuContextuel($RefMenu)
//EXECUTE METHOD IN SUBFORM("AffichageArbre"; Formula from string("cs.$menus.new().FixerMenuContextuel($1)"); *; $RefMenu)
APPEND MENU ITEM($RefMenu; "Menu 3 Form process encore"; *)
SET MENU ITEM PARAMETER($RefMenu; -1; "toto 3")
$ligneMenu:=Dynamic pop up menu($RefMenu)
If ($ligneMenu="")
// filtrer
Else
Form.arbre.menu.ExecuterCommandeContextuel($ligneMenu)
//EXECUTE METHOD IN SUBFORM("AffichageArbre"; Formula from string("cs.$menus.new().ExecuterCommandeContextuel($1)"); *; $ligneMenu)
//EXÉCUTER MÉTHODE DANS SOUS FORMULAIRE("AffichageArbre"; "Menus Contextuels AG"; $x; Commande Menu; ->$RefMenu; ->$ligneMenu)
End if
RELEASE MENU($RefMenu)
Else
End case
End case
⇧
[ ]Test Visualiser Arbre - objet avancement - 07/12/2021 18:01:18
Curseur Busy(0x02000000) // RAZ
⇧
[ ]Test Visualiser Arbre - objet btnView - 04/02/2025 18:48:47
var $options : Integer
$options:=SVG_Get_options
// vaut 0x01BBC, bits 2,3,4,5,7,8,9,11,12
//SVG_SET_OPTIONS(0)
SVGTool_SHOW_IN_VIEWER(arbreDOM)
DOM EXPORT TO FILE(arbreDOM; Get 4D folder(Logs folder)+"testStructureSVG.xml")
⇧
[ ]Test Visualiser Arbre - objet AffichageArbre - 03/02/2026 12:12:43
var $paramsArbre : Object
Case of
: (Form event code=ALV sur Modification)
$paramsArbre:=OB Copy(Form.paramsArbre)
cs.$arbre.new().Modifier_AG($paramsArbre)
: (Form event code=ALV sur Navigation)
BEEP
//: (Form event code=ALV sur Survol Element)
//BEEP
//// affichage, pour debug :
//// attention : ici on n'est pas dans le sous formulaire : Form n'existe pas, mais 'paramsArbre' est à jour
//Form.numTable:=Form.paramsArbre.Navigation.ZS.numTable
//Form.UUID_BDD:=Form.paramsArbre.Navigation.ZS.UUID_BDD
//Form.OverElementID_SVG:=Form.paramsArbre.EtatProcessus.OverElementID_SVG
//Form.SelectedElementID_SVG:=Form.paramsArbre.EtatProcessus.SelectedElementID_SVG
//Form.OverInformationID_SVG:=Form.paramsArbre.EtatProcessus.OverInformationID_SVG
//Form.SelectedInformationID_SVG:=Form.paramsArbre.EtatProcessus.SelectedInformationID_SVG
//Form.PositionX:=-1
//Form.PositionY:=-1
//If (OB Is defined(Form.paramsArbre.EtatProcessus; "PositionX"))
//Form.PositionX:=Form.paramsArbre.EtatProcessus.PositionX
//Form.PositionY:=Form.paramsArbre.EtatProcessus.PositionY
//End if
End case
⇧
onStartup - 09/02/2026 10:35:21
// ne s'exécute pas dans une base hôte
ON ERR CALL(Formula(traceHandler).source; ek global)
cs._composant.new().InitVariablesARB()
// pour les tests hors base hôte
CALL WORKER("WK_DeployerArbre"; Formula(InitProcess).source)
⇧
onExit - 06/04/2025 10:22:27
// ne s'exécute pas dans une base hôte
// exporter le code du composant si pas compilé
ON ERR CALL(Formula(traceHandler).source; ek local)
cs.xSDK.ExportCode4D.new().DémarrerComposant()
⇧
onSystemEvent - 07/12/2021 18:01:26
Pas de code
⇧
onHostDatabaseEvent - 09/02/2026 10:35:41
#DECLARE($numEvent : Integer)
Case of
: ($numEvent=On before host database startup)
ON ERR CALL(Formula(traceHandler).source; ek local)
cs._composant.new().InitVariablesARB()
Use (Storage.System)
Storage.System.EstExecuteDansHote:=True
End use
// déactiver les ASSERT si le composant est compilé (réactivable avec les options d'appel par la base hôte)
SET ASSERT ENABLED(Not(Is compiled mode))
// remarque : le worker WK_services a été créé par ailleurs
// créer le worker du calcul du déploiement
CALL WORKER("WK_DeployerArbre"; Formula(InitProcess).source)
: ($numEvent=On after host database startup)
ON ERR CALL(Formula(traceHandler).source; ek global)
cs._composant.new().Installer()
: ($numEvent=On before host database exit)
// placer ici le code à exécuter avant le "Sur fermeture" de la base hôte
: ($numEvent=On after host database exit)
// placer ici le code à exécuter après le "Sur fermeture" de la base hôte
End case