easylinux/SignauxComplexes
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

V2.3B

Browse Source
This commit is contained in:
f1iwq2
2020-12-23 12:12:19 +01:00
parent 77b55f6aee
commit db036a7bd8
16 changed files with 1434 additions and 2764 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
UnitConfig.dcu
View File

Binary file not shown.

47
UnitConfig.dfm
View File

@@ -1776,7 +1776,7 @@ object FormConfig: TFormConfig
Top = 8
Width = 585
Height = 441
ActivePage = TabSheetSig
ActivePage = TabSheetAct
Font.Charset = DEFAULT_CHARSET
Font.Color = clBackground
Font.Height = -11
@@ -2783,7 +2783,7 @@ object FormConfig: TFormConfig
Top = 48
Width = 129
Height = 21
ItemHeight = 13
ItemHeight = 0
TabOrder = 1
OnChange = ComboBoxDecChange
end
@@ -2895,31 +2895,13 @@ object FormConfig: TFormConfig
'Liste de mod'#233'lisation des actionneurs du fichier config.cfg - cl' +
'iquez sur une ligne pour afficher la description de l'#39'action'
end
object MemoAct: TMemo
Left = 0
Top = 24
Width = 289
Height = 369
Color = clInfoText
Font.Charset = DEFAULT_CHARSET
Font.Color = clAqua
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
ReadOnly = True
ScrollBars = ssVertical
TabOrder = 0
WordWrap = False
OnClick = MemoActClick
end
object GroupBox13: TGroupBox
Left = 304
Top = 32
Width = 257
Height = 345
Caption = 'Description de l'#39'actionneur '
TabOrder = 1
TabOrder = 0
object GroupBox14: TGroupBox
Left = 16
Top = 24
@@ -2957,7 +2939,7 @@ object FormConfig: TFormConfig
end
object GroupBoxAct: TGroupBox
Left = 8
Top = 200
Top = 216
Width = 225
Height = 145
Caption = 'Actionneur fonction de locomotive '
@@ -3011,6 +2993,7 @@ object FormConfig: TFormConfig
Height = 21
TabOrder = 0
Text = 'EditAct'
OnChange = EditActChange
end
object EditTrain: TEdit
Left = 112
@@ -3019,6 +3002,7 @@ object FormConfig: TFormConfig
Height = 21
TabOrder = 1
Text = 'EditTrain'
OnChange = EditTrainChange
end
object EditEtatFoncSortie: TEdit
Left = 160
@@ -3027,6 +3011,7 @@ object FormConfig: TFormConfig
Height = 21
TabOrder = 2
Text = 'EditEtatFoncSortie'
OnChange = EditEtatFoncSortieChange
end
object EditFonctionAccess: TEdit
Left = 112
@@ -3035,6 +3020,7 @@ object FormConfig: TFormConfig
Height = 21
TabOrder = 3
Text = 'EditFonc'
OnChange = EditFonctionAccessChange
end
object EditTempo: TEdit
Left = 112
@@ -3043,6 +3029,7 @@ object FormConfig: TFormConfig
Height = 21
TabOrder = 4
Text = 'EditTempo'
OnChange = EditTempoChange
end
object EditEtatActionneur: TEdit
Left = 184
@@ -3051,6 +3038,7 @@ object FormConfig: TFormConfig
Height = 21
TabOrder = 5
Text = 'EditEtat'
OnChange = EditEtatActionneurChange
end
object CheckRAZ: TCheckBox
Left = 48
@@ -3059,11 +3047,12 @@ object FormConfig: TFormConfig
Height = 17
Caption = 'Remise '#224' 0 apr'#232's pilotage'
TabOrder = 6
OnClick = CheckRAZClick
end
end
object GroupBoxPN: TGroupBox
Left = 72
Top = 8
Left = 56
Top = 56
Width = 225
Height = 193
Caption = 'Actionneurs gestion passage '#224' niveau'
@@ -3207,6 +3196,16 @@ object FormConfig: TFormConfig
end
end
end
object RichAct: TRichEdit
Left = 0
Top = 32
Width = 289
Height = 369
Color = clBlack
ScrollBars = ssVertical
TabOrder = 1
OnMouseDown = RichActMouseDown
end
end
end
end

238
UnitConfig.pas
View File

@@ -77,7 +77,6 @@ type
Label15: TLabel;
TabSheetAct: TTabSheet;
Label16: TLabel;
MemoAct: TMemo;
CheckBoxSrvSig: TCheckBox;
Memo1: TMemo;
Memo2: TMemo;
@@ -185,12 +184,12 @@ type
GroupBox15: TGroupBox;
EditNbDetDist: TEdit;
Label31: TLabel;
RichAct: TRichEdit;
procedure ButtonAppliquerEtFermerClick(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure MemoSignauxClick(Sender: TObject);
procedure MemoActClick(Sender: TObject);
procedure PageControlChange(Sender: TObject);
procedure RichAigMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
@@ -213,6 +212,15 @@ type
procedure EditSuiv3Change(Sender: TObject);
procedure EditDet4Change(Sender: TObject);
procedure EditSuiv4Change(Sender: TObject);
procedure EditActChange(Sender: TObject);
procedure RichActMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure EditEtatActionneurChange(Sender: TObject);
procedure EditTrainChange(Sender: TObject);
procedure EditFonctionAccessChange(Sender: TObject);
procedure EditEtatFoncSortieChange(Sender: TObject);
procedure EditTempoChange(Sender: TObject);
procedure CheckRAZClick(Sender: TObject);
private
{ Déclarations privées }
public
@@ -267,7 +275,7 @@ var temps : integer;
begin
if SocketCDM_connecte=false then begin envoi_CDM:=false;exit;end;
//Affiche('Envoi à CDM rail',clRed);Affiche(s,ClGreen);
if trace then affiche(s,clLime);
if traceTrames then afficheDebug(s,clLime);
Formprinc.ClientSocketCDM.Socket.SendText(s);
// attend l'ack
ackCDM:=false;nackCDM:=false;
@@ -333,7 +341,7 @@ begin
end;
procedure connecte_CDM;
var s , ss : string;
var s : string;
i : integer;
begin
// déconnexion de l'ancienne liaison éventuelle
@@ -389,7 +397,7 @@ end;
// teste si une adresse IP V4 est ok
function Ipok(s : string) : boolean;
var i,k,posp,n,octet,erreur : integer;
var i,k,octet,erreur : integer;
begin
for k:=1 to 3 do
begin
@@ -405,7 +413,7 @@ end;
// vérifie si la config de la com série/usb est ok
function config_com(s : string) : boolean;
var sa : string;
j,i,erreur : integer;
i,erreur : integer;
begin
sa:=s;
protocole:=-1;
@@ -414,19 +422,15 @@ begin
if i<>0 then
begin
delete(s,1,i);
j:=i;
i:=pos(',',s);
j:=j+i;
if i<>0 then
begin
delete(s,1,i);
i:=pos(',',s);
j:=j+i;
if i<>0 then
begin
delete(s,1,i);
i:=pos(',',s);
j:=j+i;
if i<>0 then
begin
delete(s,1,i);
@@ -564,6 +568,30 @@ begin
encode_sig:=s;
end;
// transforme l'actionneur type loco ou actionneur du tableau en texte
// paramètre d'entrée : index
function encode_act_loc(i : integer): string;
var s : string;
c : char;
adresse : integer;
begin
// adresse
adresse:=Tablo_Actionneur[i].actionneur;
if adresse=0 then begin encode_act_loc:='';exit;end;
if Formconfig.radioButtonLoc.Checked then
s:=IntToSTR(adresse)+','+IntToSTR(Tablo_Actionneur[i].Etat)+','+Tablo_Actionneur[i].train+',F'+IntToSTR(Tablo_Actionneur[i].fonction)+','+intToSTR(Tablo_Actionneur[i].tempo);
if FormConfig.RadioButtonAccess.Checked then
begin
s:=IntToSTR(adresse)+','+IntToSTR(Tablo_Actionneur[i].Etat)+','+Tablo_Actionneur[i].train+
',A'+IntToSTR(Tablo_Actionneur[i].accessoire)+','+intToSTR(Tablo_Actionneur[i].sortie)+',';
if Tablo_Actionneur[i].Raz then s:=s+'Z' else s:=s+'S';
end;
encode_act_loc:=s;
end;
// modifie les fichiers de config en fonction du paramétrage
procedure genere_config;
var s: string;
@@ -1040,7 +1068,10 @@ begin
// actionneurs
for i:=1 to maxTablo_act do
MemoAct.Lines.Add(mod_Act[i]);
begin
RichAct.Lines.Add(mod_Act[i]);
RE_ColorLine(RichAct,RichAct.lines.count-1,ClAqua)
end;
PageControl.ActivePage:=TabSheetCDM; // force le premier onglet sur la page
for i:=1 to NbDecodeur do
@@ -1415,9 +1446,12 @@ var i,v, ligne,etatact,erreur, adresse,sortie,fonction,tempo,access : integer;
s,s2,ss : string;
trouve : bool;
begin
with formConfig.MemoAct do
with formConfig.RichAct do
begin
ligne:=Perform(EM_LINEFROMCHAR,-1,0); // numéro de la lignée cliquée
AncLigneCliquee:=Ligne;
ligneCliquee:=ligne;
//affiche(intToSTR(ligne),clLime);
s:=Uppercase(Lines[ligne]);
if s='' then exit;
SelStart:=Perform(EM_LINEINDEX,Ligne,0); // début de la sélection
@@ -1578,11 +1612,6 @@ begin
Aff_champs_sig;
end;
procedure TFormConfig.MemoActClick(Sender: TObject);
begin
Aff_champs_act;
end;
procedure TFormConfig.PageControlChange(Sender: TObject);
begin
if PageControl.ActivePage=TabSheetAig then
@@ -2114,6 +2143,181 @@ begin
end;
end;
procedure TFormConfig.EditActChange(Sender: TObject);
var s : string;
act,erreur : integer;
begin
if clicliste then exit;
if FormConfig.PageControl.ActivePage=FormConfig.TabSheetAct then
with Formconfig do
begin
s:=EditAct.Text;
if radioButtonLoc.Checked or RadioButtonAccess.Checked then
begin
Val(s,act,erreur);
if erreur<>0 then
begin
LabelInfo.caption:='Erreur adresse actionneur';exit
end else LabelInfo.caption:=' ';
tablo_actionneur[lignecliquee+1].actionneur:=act;
s:=encode_act_loc(lignecliquee+1);
RichAct.Lines[lignecliquee]:=s;
end;
end;
end;
procedure TFormConfig.RichActMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
clicliste:=true;
LabelInfo.caption:='';
Aff_champs_Act;
clicliste:=false;
end;
procedure TFormConfig.EditEtatActionneurChange(Sender: TObject);
var s : string;
etat,erreur : integer;
begin
if clicliste then exit;
if FormConfig.PageControl.ActivePage=FormConfig.TabSheetAct then
with Formconfig do
begin
s:=EditEtatActionneur.Text;
if radioButtonLoc.Checked or RadioButtonAccess.Checked then
begin
Val(s,etat,erreur);
if (erreur<>0) or (etat<0) or (etat>1) then
begin
LabelInfo.caption:='Erreur état actionneur';exit
end else LabelInfo.caption:=' ';
tablo_actionneur[lignecliquee+1].etat:=etat;
s:=encode_act_loc(lignecliquee+1);
RichAct.Lines[lignecliquee]:=s;
end;
end;
end;
procedure TFormConfig.EditTrainChange(Sender: TObject);
var s,train : string;
begin
if clicliste then exit;
if FormConfig.PageControl.ActivePage=FormConfig.TabSheetAct then
with Formconfig do
begin
if radioButtonLoc.Checked or RadioButtonAccess.Checked then
begin
train:=editTrain.Text;
if train='' then
begin
LabelInfo.caption:='Erreur train';exit
end else LabelInfo.caption:=' ';
tablo_actionneur[lignecliquee+1].train:=train;
s:=encode_act_loc(lignecliquee+1);
RichAct.Lines[lignecliquee]:=s;
end;
end;
end;
procedure TFormConfig.EditFonctionAccessChange(Sender: TObject);
var s : string;
fonction,erreur : integer;
begin
if clicliste then exit;
if FormConfig.PageControl.ActivePage=FormConfig.TabSheetAct then
with Formconfig do
begin
s:=EditFonctionAccess.Text;
if radioButtonLoc.Checked or RadioButtonAccess.Checked then
begin
Val(s,fonction,erreur);
if erreur<>0 then
begin
LabelInfo.caption:='Erreur fonction actionneur';exit
end else LabelInfo.caption:=' ';
if radioButtonLoc.Checked then tablo_actionneur[lignecliquee+1].fonction:=fonction;
if RadioButtonAccess.Checked then Tablo_Actionneur[lignecliquee+1].accessoire:=fonction;
s:=encode_act_loc(lignecliquee+1);
RichAct.Lines[lignecliquee]:=s;
end;
end;
end;
procedure TFormConfig.EditEtatFoncSortieChange(Sender: TObject);
var s : string;
Etat,erreur : integer;
begin
if clicliste then exit;
if FormConfig.PageControl.ActivePage=FormConfig.TabSheetAct then
with Formconfig do
begin
s:=EditEtatFoncSortie.Text;
if radioButtonAccess.Checked then
begin
Val(s,etat,erreur);
if (erreur<>0) or (etat<0) or (etat>2) then
begin
LabelInfo.caption:='Erreur Etat actionneur';exit
end else LabelInfo.caption:=' ';
tablo_actionneur[lignecliquee+1].sortie:=etat;
s:=encode_act_loc(lignecliquee+1);
RichAct.Lines[lignecliquee]:=s;
end;
end;
end;
procedure TFormConfig.EditTempoChange(Sender: TObject);
var s : string;
tempo,erreur : integer;
begin
if clicliste then exit;
if FormConfig.PageControl.ActivePage=FormConfig.TabSheetAct then
with Formconfig do
begin
s:=EditTempo.Text;
if radioButtonLoc.Checked then
begin
Val(s,tempo,erreur);
if erreur<>0 then
begin
LabelInfo.caption:='Erreur Tempo actionneur';exit
end else LabelInfo.caption:=' ';
tablo_actionneur[lignecliquee+1].tempo:=tempo;
s:=encode_act_loc(lignecliquee+1);
RichAct.Lines[lignecliquee]:=s;
end;
end;
end;
procedure TFormConfig.CheckRAZClick(Sender: TObject);
var s : string;
Etat,erreur : integer;
begin
if clicliste then exit;
if FormConfig.PageControl.ActivePage=FormConfig.TabSheetAct then
with Formconfig do
begin
if radioButtonAccess.Checked then
begin
tablo_actionneur[lignecliquee+1].raz:=CheckRAZ.checked;
s:=encode_act_loc(lignecliquee+1);
RichAct.Lines[lignecliquee]:=s;
end;
end;
end;
end.

BIN
UnitDebug.dcu
View File

Binary file not shown.

87
UnitDebug.dfm
View File

@@ -1,7 +1,7 @@
object FormDebug: TFormDebug
Left = 329
Top = 122
Width = 842
Width = 855
Height = 762
Caption = 'Fen'#234'tre de d'#233'bug'
Color = clWindow
@@ -15,12 +15,12 @@ object FormDebug: TFormDebug
Position = poMainFormCenter
OnCreate = FormCreate
DesignSize = (
826
839
724)
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 642
Left = 655
Top = 4
Width = 108
Height = 13
@@ -36,7 +36,7 @@ object FormDebug: TFormDebug
ParentFont = False
end
object Label2: TLabel
Left = 474
Left = 487
Top = 2
Width = 131
Height = 18
@@ -50,7 +50,7 @@ object FormDebug: TFormDebug
ParentFont = False
end
object Label3: TLabel
Left = 472
Left = 485
Top = 160
Width = 99
Height = 185
@@ -68,7 +68,7 @@ object FormDebug: TFormDebug
WordWrap = True
end
object EditNivDebug: TEdit
Left = 754
Left = 767
Top = 2
Width = 49
Height = 21
@@ -84,7 +84,7 @@ object FormDebug: TFormDebug
OnKeyPress = EditNivDebugKeyPress
end
object MemoEvtDet: TMemo
Left = 578
Left = 591
Top = 344
Width = 239
Height = 225
@@ -103,7 +103,7 @@ object FormDebug: TFormDebug
TabOrder = 1
end
object ButtonEcrLog: TButton
Left = 474
Left = 487
Top = 464
Width = 97
Height = 29
@@ -112,52 +112,40 @@ object FormDebug: TFormDebug
TabOrder = 2
OnClick = ButtonEcrLogClick
end
object MemoDebug: TMemo
Left = 0
Top = 0
Width = 465
Height = 721
Anchors = [akLeft, akTop, akRight, akBottom]
Lines.Strings = (
'MemoDebug')
ScrollBars = ssBoth
TabOrder = 3
WordWrap = False
end
object ButtonRazTampon: TButton
Left = 474
Left = 487
Top = 536
Width = 97
Height = 33
Anchors = [akTop, akRight]
Caption = 'Raz Tampon Ev'#232'nements ---->'
TabOrder = 4
TabOrder = 3
WordWrap = True
OnClick = ButtonRazTamponClick
end
object ButtonCherche: TButton
Left = 474
Left = 487
Top = 432
Width = 97
Height = 25
Anchors = [akTop, akRight]
Caption = 'Chercher erreurs'
TabOrder = 5
TabOrder = 4
OnClick = ButtonChercheClick
end
object ButtonAffEvtChrono: TButton
Left = 474
Left = 487
Top = 392
Width = 97
Height = 33
Anchors = [akTop, akRight]
Caption = 'Affiche Evts d'#233'tecteurs et aig'
TabOrder = 6
TabOrder = 5
WordWrap = True
OnClick = ButtonAffEvtChronoClick
end
object ButtonCop: TButton
Left = 474
Left = 487
Top = 344
Width = 97
Height = 41
@@ -169,34 +157,40 @@ object FormDebug: TFormDebug
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
TabOrder = 7
TabOrder = 6
WordWrap = True
OnClick = ButtonCopClick
end
object RichEdit: TRichEdit
Left = 578
Left = 591
Top = 160
Width = 239
Height = 185
Anchors = [akTop, akRight]
Font.Charset = DEFAULT_CHARSET
Font.Color = clWhite
Font.Height = -11
Font.Name = 'Arial'
Font.Style = []
HideScrollBars = False
ParentFont = False
PopupMenu = PopupMenuRE
ScrollBars = ssVertical
TabOrder = 8
TabOrder = 7
end
object ButtonRazLog: TButton
Left = 474
Left = 487
Top = 496
Width = 97
Height = 33
Anchors = [akTop, akRight]
Caption = 'Raz Tampon Log <-----'
TabOrder = 9
TabOrder = 8
WordWrap = True
OnClick = ButtonRazLogClick
end
object GroupBox1: TGroupBox
Left = 472
Left = 485
Top = 576
Width = 353
Height = 145
@@ -210,7 +204,7 @@ object FormDebug: TFormDebug
Font.Style = []
ParentColor = False
ParentFont = False
TabOrder = 10
TabOrder = 9
object GroupBox3: TGroupBox
Left = 8
Top = 16
@@ -332,7 +326,7 @@ object FormDebug: TFormDebug
end
end
object GroupBox2: TGroupBox
Left = 472
Left = 485
Top = 20
Width = 345
Height = 137
@@ -346,7 +340,7 @@ object FormDebug: TFormDebug
Font.Style = []
ParentColor = False
ParentFont = False
TabOrder = 11
TabOrder = 10
object CheckAffSig: TCheckBox
Left = 8
Top = 16
@@ -455,6 +449,19 @@ object FormDebug: TFormDebug
OnClick = CheckBoxAffDebDecSigClick
end
end
object RichDebug: TRichEdit
Left = 8
Top = 8
Width = 470
Height = 705
Anchors = [akLeft, akTop, akRight, akBottom]
Lines.Strings = (
'RichDebug')
PopupMenu = PopupMenuRD
ScrollBars = ssBoth
TabOrder = 11
OnChange = RichDebugChange
end
object SaveDialog: TSaveDialog
Left = 768
Top = 488
@@ -467,4 +474,12 @@ object FormDebug: TFormDebug
OnClick = copier1Click
end
end
object PopupMenuRD: TPopupMenu
Left = 808
Top = 360
object Copier2: TMenuItem
Caption = 'Copier'
OnClick = Copier2Click
end
end
end

55
UnitDebug.pas
View File

@@ -15,7 +15,6 @@ type
SaveDialog: TSaveDialog;
ButtonEcrLog: TButton;
Label3: TLabel;
MemoDebug: TMemo;
ButtonRazTampon: TButton;
ButtonCherche: TButton;
ButtonAffEvtChrono: TButton;
@@ -44,6 +43,9 @@ type
EditActuel: TEdit;
Button1: TButton;
Button2: TButton;
RichDebug: TRichEdit;
PopupMenuRD: TPopupMenu;
Copier2: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure ButtonEcrLogClick(Sender: TObject);
procedure EditNivDebugKeyPress(Sender: TObject; var Key: Char);
@@ -65,6 +67,8 @@ type
procedure ButtonCanSuivSigClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Copier2Click(Sender: TObject);
procedure RichDebugChange(Sender: TObject);
private
{ Déclarations privées }
public
@@ -113,11 +117,6 @@ uses UnitPrinc;
{$R *.dfm}
procedure AfficheDebug(s : string;lacouleur : TColor);
begin
FormDebug.MemoDebug.Lines.add(s);
end;
procedure RE_ColorLine(ARichEdit : TRichEdit;ARow : Integer;AColor : TColor);
begin
with ARichEdit do
@@ -129,6 +128,13 @@ begin
end;
end;
procedure AfficheDebug(s : string;lacouleur : TColor);
begin
FormDebug.RichDebug.Lines.add(s);
RE_ColorLine(FormDebug.RichDebug,FormDebug.RichDebug.lines.count-1,lacouleur);
end;
procedure TFormDebug.FormCreate(Sender: TObject);
var s: string;
i : integer;
@@ -138,14 +144,14 @@ begin
s:=s+'comportement du programme. Positionner le niveau de 1 à 3 pour';
s:=s+' afficher des informations plus ou moins détaillées.';
Label3.caption:=s;
MemoDebug.WordWrap:=false; // interdit la coupure des chaînes en limite du composant
MemoDebug.color:=$33;
RichDebug.WordWrap:=false; // interdit la coupure des chaînes en limite du composant
RichDebug.color:=$33;
initform:=false;
MemoDebug.clear;
RichDebug.clear;
s:=DateToStr(date)+' '+TimeToStr(Time)+' ';
if IsWow64Process then s:=s+' OS 64 Bits' else s:=s+' OS 32 Bits';
RichEdit.color:=$111122;
MemoDebug.Lines.add(s);
RichDebug.Lines.add(s);
end;
procedure TFormDebug.ButtonEcrLogClick(Sender: TObject);
@@ -163,7 +169,7 @@ begin
assignFile(fte,s);
rewrite(fte);
writeln(fte,s);
with MemoDebug do
with RichDebug do
for i:=0 to Lines.Count do
begin
writeln(fte,Lines[i]);
@@ -186,7 +192,7 @@ begin
end
else EditNivDebug.text:='0';
end;
MemoDebug.Lines.add('Niveau='+intToSTR(NivDebug));
RichDebug.Lines.add('Niveau='+intToSTR(NivDebug));
end;
@@ -208,7 +214,7 @@ var i : integer;
trouve : boolean;
begin
with MemoDebug do
with RichDebug do
begin
i:=0;
repeat
@@ -229,7 +235,7 @@ procedure TFormDebug.ButtonAffEvtChronoClick(Sender: TObject);
var i,j,etat : integer;
s : string;
begin
MemoDebug.Clear;
RichDebug.Clear;
if N_event_tick=0 then
begin
AfficheDebug('Il n''y a aucun évènement détecteur ou aiguillage',clyellow);
@@ -269,17 +275,15 @@ end;
procedure TFormDebug.CheckTrameClick(Sender: TObject);
begin
trace:=CheckTrame.Checked;
traceTrames:=CheckTrame.Checked;
end;
procedure TFormDebug.ButtonCopClick(Sender: TObject);
var i : integer;
begin
MemoDebug.Lines:=Formprinc.ListBox1.Items
RichDebug.Lines:=Formprinc.FenRich.lines;
end;
procedure TFormDebug.copier1Click(Sender: TObject);
begin
RichEdit.SelectAll;
@@ -289,7 +293,7 @@ end;
procedure TFormDebug.ButtonRazLogClick(Sender: TObject);
begin
MemoDebug.Clear;
RichDebug.Clear;
end;
procedure TFormDebug.CheckBoxActClick(Sender: TObject);
@@ -376,4 +380,17 @@ begin
NivDebug:=AncDebug;
end;
procedure TFormDebug.Copier2Click(Sender: TObject);
begin
RichDebug.SelectAll;
RichDebug.CopyToClipboard;
RichDebug.SetFocus;
end;
// pour déplacer l'ascenseur de l'affichage automatiquement en bas
procedure TFormDebug.RichDebugChange(Sender: TObject);
begin
SendMessage(RichDebug.handle, WM_VSCROLL, SB_BOTTOM, 0);
end;
end.

BIN
UnitPrinc.dcu
View File

Binary file not shown.

61
UnitPrinc.dfm
View File

@@ -1,6 +1,6 @@
object FormPrinc: TFormPrinc
Left = 12
Top = 210
Left = 1296
Top = 222
Width = 1212
Height = 664
Caption = 'Client TCP-IP CDM Rail ou USB - syst'#232'me LENZ'
@@ -1201,24 +1201,6 @@ object FormPrinc: TFormPrinc
Font.Style = []
ParentFont = False
end
object ListBox1: TListBox
Left = 8
Top = 48
Width = 609
Height = 505
Style = lbOwnerDrawFixed
Anchors = [akLeft, akTop, akRight, akBottom]
Color = clBlack
Font.Charset = ANSI_CHARSET
Font.Color = clBlue
Font.Height = 16
Font.Name = 'Arial'
Font.Style = []
ItemHeight = 16
ParentFont = False
TabOrder = 0
OnDrawItem = ListBox1DrawItem
end
object ScrollBox1: TScrollBox
Left = 631
Top = 168
@@ -1231,7 +1213,7 @@ object FormPrinc: TFormPrinc
Anchors = [akTop, akRight, akBottom]
Color = clWhite
ParentColor = False
TabOrder = 1
TabOrder = 0
end
object GroupBox1: TGroupBox
Left = 631
@@ -1240,7 +1222,7 @@ object FormPrinc: TFormPrinc
Height = 129
Anchors = [akTop, akRight]
Caption = 'Commande d'#39'accessoires'
TabOrder = 2
TabOrder = 1
object Label2: TLabel
Left = 7
Top = 16
@@ -1339,7 +1321,7 @@ object FormPrinc: TFormPrinc
Width = 281
Height = 129
Anchors = [akTop, akRight]
TabOrder = 5
TabOrder = 4
object BoutonRaf: TButton
Left = 8
Top = 8
@@ -1439,7 +1421,7 @@ object FormPrinc: TFormPrinc
Height = 25
Anchors = [akTop, akRight]
Caption = 'Panel2'
TabOrder = 6
TabOrder = 5
object Label1: TLabel
Left = 16
Top = 4
@@ -1468,7 +1450,26 @@ object FormPrinc: TFormPrinc
Height = 17
Anchors = [akLeft, akRight, akBottom]
Caption = 'xx'
TabOrder = 6
end
object FenRich: TRichEdit
Left = 8
Top = 48
Width = 617
Height = 497
Anchors = [akLeft, akTop, akRight, akBottom]
Color = clBlack
Font.Charset = DEFAULT_CHARSET
Font.Color = clYellow
Font.Height = -13
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
PopupMenu = PopupMenuFenRich
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 7
OnChange = FenRichChange
end
object Timer1: TTimer
Interval = 100
@@ -1499,6 +1500,10 @@ object FormPrinc: TFormPrinc
Caption = 'Etat des aiguillages'
OnClick = Etatdesaiguillages1Click
end
object Etatdessignaux1: TMenuItem
Caption = 'Etat des signaux'
OnClick = Etatdessignaux1Click
end
object N3: TMenuItem
Caption = '-'
end
@@ -1611,4 +1616,12 @@ object FormPrinc: TFormPrinc
Left = 888
Top = 16
end
object PopupMenuFenRich: TPopupMenu
Left = 208
Top = 24
object Copier1: TMenuItem
Caption = 'Copier'
OnClick = Copier1Click
end
end
end

175
UnitPrinc.pas
View File

@@ -20,7 +20,6 @@ uses
type
TFormPrinc = class(TForm)
ListBox1: TListBox;
Timer1: TTimer;
LabelTitre: TLabel;
ScrollBox1: TScrollBox;
@@ -91,6 +90,10 @@ type
ButtonLanceCDM: TButton;
Affichefentredebug1: TMenuItem;
StaticText: TStaticText;
FenRich: TRichEdit;
PopupMenuFenRich: TPopupMenu;
Copier1: TMenuItem;
Etatdessignaux1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure MSCommUSBLenzComm(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
@@ -98,8 +101,6 @@ type
procedure BoutVersionClick(Sender: TObject);
procedure ButtonCommandeClick(Sender: TObject);
procedure EditvalEnter(Sender: TObject);
procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure BoutonRafClick(Sender: TObject);
procedure ClientSocketLenzError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
@@ -143,7 +144,9 @@ type
procedure ButtonAffTCOClick(Sender: TObject);
procedure ButtonLanceCDMClick(Sender: TObject);
procedure Affichefentredebug1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FenRichChange(Sender: TObject);
procedure Copier1Click(Sender: TObject);
procedure Etatdessignaux1Click(Sender: TObject);
private
{ Déclarations privées }
procedure DoHint(Sender : Tobject);
@@ -236,7 +239,7 @@ var
branche : array [1..100] of string;
FormPrinc: TFormPrinc;
ack,portCommOuvert,trace,AffMem,AfficheDet,CDM_connecte,SocketCDM_connecte,
ack,portCommOuvert,traceTrames,AffMem,AfficheDet,CDM_connecte,SocketCDM_connecte,
Raz_Acc_signaux,AvecInit,AvecTCO,terminal,Srvc_Aig,Srvc_Det,Srvc_Act,
Srvc_PosTrain,Srvc_Sig,debugtrames : boolean;
tablo : array of byte; // tableau rx usb
@@ -414,10 +417,8 @@ begin
begin
brush.Color:=couleur;
Pen.Color:=clBlack;
//Affiche('clignote '+IntToSTR(x)+' '+intToSTR(y),clyellow);
Ellipse(x-rayon,y-rayon,x+rayon,y+rayon);
end;
//Affiche(IntToSTR(y),clyellow);
end;
// dessine les feux sur une cible à 2 feux dans le canvas spécifié
@@ -1045,7 +1046,7 @@ begin
cercle(ACanvas,12,13,6,GrisF);
cercle(ACanvas,25,13,6,GrisF);
end;
if EtatSignal=1 then
if EtatSignal=1 then
begin
cercle(ACanvas,12,13,6,clWhite);
cercle(ACanvas,25,13,6,GrisF);
@@ -1058,19 +1059,18 @@ begin
end;
// affiche un texte dans la fenêtre
procedure Affiche(s : string;lacouleur : TColor);
begin
couleur:=lacouleur;
with formprinc.ListBox1 do
with formprinc do
begin
Items.addObject(s,pointer(lacouleur));
TopIndex:= Items.Count - 1;
FenRich.lines.add(s);
RE_ColorLine(FenRich,FenRich.lines.count-1,lacouleur);
//FenRich.SetFocus;
//FenRich.SelStart := FenRich.GetTextLen;
//FenRich.Perform(EM_SCROLLCARET, 0, 0);
end;
end;
// renvoie l'index du feu dans le tableau feux[] en fonction de son adresse
//si pas de feu renvoie 0
function Index_feu(adresse : integer) : integer;
@@ -1265,7 +1265,7 @@ end;
// Affiche une chaîne en Hexa Ascii
procedure affiche_chaine_hex(s : string;couleur : Tcolor);
begin
if trace then Affiche(chaine_HEX(s),couleur);
if traceTrames then AfficheDebug(chaine_HEX(s),couleur);
end;
// temporisation en x 100 ms (0,1 s)
@@ -1285,7 +1285,7 @@ var i,timeout,valto : integer;
begin
// com:=formprinc.MSCommUSBLenz;
s:=entete+s+suffixe;
if Trace then Affiche('Tick='+IntToSTR(tick)+'/Env '+chaine_Hex(s),ClGreen);
if traceTrames then AfficheDebug('Tick='+IntToSTR(tick)+'/Env '+chaine_Hex(s),ClGreen);
// par port com-usb
if portCommOuvert then
@@ -3570,10 +3570,9 @@ begin
//affiche(s,cllime);
sa:=uppercase(Fonte_ch)+'=';
i:=pos(sa,s);
if i<>0 then
if i<>0 then
begin
inc(nv);
trouve_fonte:=true;
inc(nv);
trouve_fonte:=true;
delete(s,i,length(sa));
TailleFonte:=StrToINT(s);
@@ -4041,8 +4040,7 @@ begin
Affiche('définition des branches',clyellow);
// branches de réseau
NDetecteurs:=0; Nligne:=1;
i:=1;i_detect:=1;
NDetecteurs:=0; Nligne:=1;
i:=1;i_detect:=1;
repeat
s:=lit_ligne;
@@ -4077,6 +4075,7 @@ begin
end
else erreur:=0; // forcer erreur à 0 pour obliger à passer sur un détecteur
end;
// détecteur
if erreur=0 then
begin
@@ -5239,7 +5238,8 @@ end;
trouve:=trouve1 or trouve2 or trouve3 or trouve4;
if not(trouve) then inc(i);
until (trouve) or (i>=100);
if trouve then Index_feu_det:=i else Index_feu_det:=0;
if trouve then Index_feu_det:=i else Index_feu_det:=0;
end;
// renvoie l'adresse du détecteur suivant des deux éléments contigus
@@ -5253,7 +5253,7 @@ begin
j:=0;
PrecCalc:=prec;
TypeprecCalc:=TypeElprec;
TypeprecCalc:=TypeElprec;
ActuelCalc:=actuel;
TypeActuelCalc:=TypeELActuel;
// étape 1 trouver le sens
@@ -5270,6 +5270,7 @@ begin
actuelCalc:=aiguillage[ActuelCalc].APointe;
end;
end;
precCalc:=actuelCalc;
TypeprecCalc:=TypeActuelCalc;
actuelCalc:=AdrSuiv;
TypeActuelCalc:=typeGen;
@@ -5398,7 +5399,7 @@ begin
// étape 1 : trouver le sens de progression (en incrément ou en décrément)
repeat
//préparer les variables
//préparer les variables
AdrPrec:=el1;TypePrec:=typeDet1;
if j=1 then i1:=IndexBranche_det1+1;
if j=2 then i1:=IndexBranche_det1-1;
@@ -5434,7 +5435,7 @@ begin
AfficheDebug(s,clorange);
end;
AdrPrec:=AdrFonc;TypePrec:=TypeFonc;
AdrPrec:=AdrFonc;TypePrec:=TypeFonc;
AdrFonc:=Adr;TypeFonc:=typeGen;
inc(i);
sortie:=((typeDet2=TypeGen) and (Adr=el2)) or (Adr=0) or (Adr>=9996) or (i=15) or (N_Det=Nb_det_dist);
@@ -5443,7 +5444,7 @@ begin
if (N_det=Nb_det_dist) and (Nivdebug=3) then afficheDebug('Détecteurs trop distants',clred);
end
else
else
begin
// déja trouvé
adr:=el2;typeGen:=TypeDet2;
@@ -5458,6 +5459,7 @@ begin
Adr:=suivant_alg3(AdrPrec,TypePrec,AdrFonc,TypeFonc,1);
//AfficheDebug('Sortie Alg3: '+IntToSTR(Adr)+'/'+intToSTR(typeGen),clyellow);
if NivDebug=3 then
begin
s:='614 : trouvé='+intToSTR(Adr);
case typeGen of
@@ -5468,7 +5470,7 @@ begin
AfficheDebug(s,clorange);
end;
AdrPrec:=AdrFonc;TypePrec:=TypeFonc;
AdrPrec:=AdrFonc;TypePrec:=TypeFonc;
AdrFonc:=Adr;TypeFonc:=typeGen;
inc(i);
sortie:=(TypeGen=1) or (Adr=0) or (Adr>=9996) or (i=10);
@@ -5482,7 +5484,7 @@ begin
affichedebug('------------------',clyellow);
end;
detecteur_suivant_el:=Adr;
exit;
exit;
end;
end;
if (i=10) then if NivDebug=3 then AfficheDebug('201 : Itération trop longue',clred);
@@ -5866,7 +5868,7 @@ begin
Affiche('Erreur 650 - feu non trouvé',clred);
AfficheDebug('Erreur 650 - feu non trouvé',clred);
test_memoire_zones:=false;
end;
end;
Pres_train:=FALSE;
ife:=1; // index feu de 1 à 4 pour explorer les 4 détecteurs d'un feu
@@ -5934,7 +5936,7 @@ begin
prec:=actuel;TypePrec:=TypeActuel;
actuel:=AdrSuiv;TypeActuel:=typeGen;
if AdrSuiv>9990 then
begin
begin
test_memoire_zones:=false;exit;
end;
@@ -6072,13 +6074,13 @@ begin
begin
test_route_valide:=0;exit;
// si manipulation proche aiguillage
det_suiv:=detecteur_suivant_el(det3,1,det2,1);
if (det_suiv>=9996) or (det1<>det_suiv) then begin test_route_valide:=0; NivDebug:=0;exit;end;
end;
test_route_valide:=10 ;
end;
// présence train 3 détecteurs avant le feu
// présence train 3 détecteurs avant le feu
function PresTrainPrec(AdrFeu : integer) : boolean;
var PresTrain : boolean;
@@ -6104,27 +6106,27 @@ begin
begin
det_initial:=feux[i].Adr_det1;Adr_El_Suiv:=feux[i].Adr_el_suiv1;
if feux[i].Btype_suiv1=1 then Btype_el_suivant:=1;
if feux[i].Btype_suiv1=2 then Btype_el_suivant:=2;
if feux[i].Btype_suiv1=4 then Btype_el_suivant:=2; // BType_suiv: 1=détecteur 2=aig ou TJD ou TJS 4=tri
end; // Btye_el_suivant: 1= détecteur 2= aiguillage 4=Buttoir
if feux[i].Btype_suiv1=2 then Btype_el_suivant:=2;
if feux[i].Btype_suiv1=4 then Btype_el_suivant:=2; // BType_suiv: 1=détecteur 2=aig ou TJD ou TJS 4=tri
end; // Btye_el_suivant: 1= détecteur 2= aiguillage 4=Buttoir
if (j=2) then
begin
det_initial:=feux[i].Adr_det2;Adr_El_Suiv:=feux[i].Adr_el_suiv2;
if feux[i].Btype_suiv2=1 then Btype_el_suivant:=1;
if feux[i].Btype_suiv1=2 then Btype_el_suivant:=2;
if feux[i].Btype_suiv1=4 then Btype_el_suivant:=2;
end;
if feux[i].Btype_suiv2=2 then Btype_el_suivant:=2;
if feux[i].Btype_suiv2=4 then Btype_el_suivant:=2;
end;
if (j=3) then
begin
det_initial:=feux[i].Adr_det3;Adr_El_Suiv:=feux[i].Adr_el_suiv3;
if feux[i].Btype_suiv3=1 then Btype_el_suivant:=1;
if feux[i].Btype_suiv1=2 then Btype_el_suivant:=2;
if feux[i].Btype_suiv1=4 then Btype_el_suivant:=2;
end;
if feux[i].Btype_suiv3=2 then Btype_el_suivant:=2;
if feux[i].Btype_suiv3=4 then Btype_el_suivant:=2;
end;
if (j=4) then
begin
det_initial:=feux[i].Adr_det4;Adr_El_Suiv:=feux[i].Adr_el_suiv4;
if feux[i].Btype_suiv1=1 then Btype_el_suivant:=1;
if feux[i].Btype_suiv4=1 then Btype_el_suivant:=1;
if feux[i].Btype_suiv4=2 then Btype_el_suivant:=2;
if feux[i].Btype_suiv4=4 then Btype_el_suivant:=2;
end;
@@ -6295,6 +6297,8 @@ begin
// sinon si signal suivant=jaune
if (TestBit(etat,jaune)) then Maj_Etat_Signal(AdrFeu,jaune_cli);
end;
end
else
// aiguille locale non déviée ou aspect feu<9
// si le signal suivant est rouge
begin
@@ -6505,7 +6509,7 @@ begin
// vérifier si le détecteur du nouveau train est associé à un feu vers un buttoir
for i:=1 to NbreFeux do
begin
begin
AdrFeu:=Feux[i].Adresse;
AdrDetfeu:=Feux[i].Adr_Det1;
if (AdrDetFeu=Det3) and (feux[i].aspect<10) then
@@ -6726,7 +6730,7 @@ begin
// sur le détecteur
for i:=1 to NbreFeux do
begin
AdrFeu:=Feux[i].Adresse;
AdrFeu:=Feux[i].Adresse;
AdrDetfeu:=Feux[i].Adr_Det1;
if (AdrDetFeu=Adresse) and (feux[i].aspect<10) then
begin
@@ -6885,22 +6889,22 @@ begin
end;
// état de l'aiguillage
if bitsITT=$00 then // module d'aiguillages, N=1
if bitsITT=$00 then // module d'aiguillages, N=1
begin
adraig:=((adresse * 4)+1 ); // *4 car N=1, c'est le "poids fort"
if (valeur and $C)=$8 then
begin
Event_Aig(adraig+3,const_droit,0);
Event_Aig(adraig+3,const_droit,0);
if traceTrames then begin s:='accessoire '+intToSTR(adraig+3)+'=2';AfficheDebug(s,clYellow);end;
end;
if (valeur and $C)=$4 then
begin
Event_Aig(adraig+3,const_devie,0);
Event_Aig(adraig+3,const_devie,0);
if traceTrames then begin s:='accessoire '+intToSTR(adraig+3)+'=1';AfficheDebug(s,clYellow);end;
end;
if (valeur and $3)=$2 then
begin
Event_Aig(adraig+2,const_droit,0);
Event_Aig(adraig+2,const_droit,0);
if traceTrames then begin s:='accessoire '+intToSTR(adraig+2)+'=2';AfficheDebug(s,clYellow);end;
end;
if (valeur and $3)=$1 then
@@ -6941,22 +6945,22 @@ begin
end;
end;
if bitsITT=$00 then // module d'aiguillages
if bitsITT=$00 then // module d'aiguillages
begin
adraig:=(adresse * 4)+1;
if (valeur and $C)=$8 then
begin
Event_Aig(adraig+1,const_droit,0);
Event_Aig(adraig+1,const_droit,0);
if traceTrames then begin s:='accessoire '+intToSTR(adraig+1)+'=2';AfficheDebug(s,clYellow);end;
end;
if (valeur and $C)=$4 then
begin
Event_Aig(adraig+1,const_devie,0);
Event_Aig(adraig+1,const_devie,0);
if traceTrames then begin s:='accessoire '+intToSTR(adraig+1)+'=1';AfficheDebug(s,clYellow);end;
end;
if (valeur and $3)=$2 then
begin
Event_Aig(adraig,const_droit,0);
Event_Aig(adraig,const_droit,0);
if traceTrames then begin s:='accessoire '+intToSTR(adraig)+'=2';AfficheDebug(s,clYellow);end;
end;
if (valeur and $3)=$1 then
@@ -6982,8 +6986,8 @@ begin
begin
case chaineINT[2] of // page 13 doc XpressNet
#1 : begin nack:=true;msg:='erreur timout transmission';end;
#2 : begin nack:=true;msg:='erreur timout centrale';end;
#3 : begin nack:=true;msg:='erreur communication inconnue';end;
#2 : begin nack:=true;msg:='erreur timout centrale';end;
#3 : begin nack:=true;msg:='erreur communication inconnue';end;
#4 : begin succes:=true;msg:='succès';end;
#5 : begin nack:=true;msg:='plus de time slot';end;
#6 : begin nack:=true;msg:='débordement tampon LI100';end;
@@ -7682,7 +7686,7 @@ begin
var i : integer;
begin
if MSCommUSBLenz.commEvent=comEvReceive then
begin
begin
tablo:=MSCommUSBLenz.Input;
for i:=0 to length(tablo)-1 do
begin
@@ -7946,17 +7950,6 @@ begin
pilote_acc(adr,valeur,aig);
end;
procedure TFormPrinc.EditvalEnter(Sender: TObject);
begin
if (Editval.Text<>'1') and (Editval.Text<>'2') then editval.text:='1';
end;
// gestion de la couleur des textes de la list box
procedure TFormPrinc.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
//with control as Tlistbox do
procedure TFormPrinc.EditvalEnter(Sender: TObject);
begin
@@ -8010,7 +8003,7 @@ procedure TFormPrinc.ClientSocketLenzRead(Sender: TObject;
ErrorCode:=0;
end;
// lecture depuis socket
// lecture depuis socket
procedure TFormPrinc.ClientSocketLenzRead(Sender: TObject;
Socket: TCustomWinSocket);
var s : string;
@@ -8035,7 +8028,6 @@ begin
procedure TFormPrinc.ButtonInfoClick(Sender: TObject);
begin
begin
Affiche('Ce programme pilote des signaux complexes de façon autonome ou avec CDM rail ',ClYellow);
Affiche('En fonction des détecteurs mis à 1 ou 0 par des locomotives',ClYellow);
@@ -8078,6 +8070,7 @@ procedure TFormPrinc.MenuConnecterEthernetClick(Sender: TObject);
procedure TFormPrinc.DeconnecterUSBClick(Sender: TObject);
begin
deconnecte_usb;
end;
procedure TFormPrinc.MenuConnecterEthernetClick(Sender: TObject);
begin
@@ -8484,20 +8477,19 @@ begin
// réception d'un message de CDM rail
procedure TFormPrinc.ClientSocketCDMRead(Sender: TObject;Socket: TCustomWinSocket);
var i,l,n : integer ;
s,ss,train : string;
s,ss,train : string;
traite,sort : boolean;
begin
inc(Nbre_recu_cdm);
begin
inc(Nbre_recu_cdm);
//if Nbre_recu_cdm>1 then Affiche('Empilement de trames CDM: '+intToSTR(Nbre_recu_cdm),clred);
recuCDM:=ClientSocketCDM.Socket.ReceiveText; // commandeCDM est le morceau tronquée de la fin de la réception précédente
recuCDM:=ClientSocketCDM.Socket.ReceiveText; // commandeCDM est le morceau tronquée de la fin de la réception précédente
//if residuCDM<>'' then Affiche(recuCDM,clLime);
if trace then
residuCDM:='';
if traceTrames then AfficheDebug(recuCDM,clWhite);
n:=80;
{begin
n:=80;
l:=length(recuCDM);
l:=length(recuCDM);
i:=0;
repeat
AfficheDebug(copy(recuCDM,(i*n)+1,n),clWhite);
@@ -8881,17 +8873,38 @@ begin
end;
procedure TFormPrinc.locoClick(Sender: TObject);
begin
// vitesse et direction 18 pas
begin
// vitesse et direction 18 pas
vitesse_loco(3,20,true);
vitesse_loco(3,20,true);
end;
// pour déplacer l'ascenseur de l'affichage automatiquement en bas
procedure TFormPrinc.FenRichChange(Sender: TObject);
begin
SendMessage(FenRich.handle, WM_VSCROLL, SB_BOTTOM, 0);
end;
procedure TFormPrinc.Copier1Click(Sender: TObject);
begin
FenRich.CopyToClipboard;
FenRich.SetFocus;
end;
procedure TFormPrinc.Etatdessignaux1Click(Sender: TObject);
var Adr,etat,i : integer;
aspect,combine : word;
s : string;
begin
for i:=1 to NbreFeux do
begin
Adr:=Feux[i].Adresse;
Etat:=Feux[i].EtatSignal;
s:='Feu '+IntToSTR(Adr)+' Etat=';
code_to_aspect(Etat,aspect,combine);
end;
s:=s+IntToSTR(etat)+'='+EtatSign[aspect]+' '+EtatSign[combine];
Affiche(s,clYellow);
end;

1609
UnitPrinc.~dfm
View File

File diff suppressed because it is too large Load Diff

1674
UnitPrinc.~pas
View File

File diff suppressed because it is too large Load Diff

BIN
UnitSimule.dcu
View File

Binary file not shown.

BIN
UnitTCO.dcu
View File

Binary file not shown.

7
verif_version.pas
View File

@@ -130,12 +130,13 @@ begin
begin
i:=pos('.zip',s);
trouve_zip:=i<>0;
if trouve_zip then s3:=s;
if trouve_zip then
s3:=s;
end;
// Aff(s)
end;
closefile(fichier);
if trouve_version then
if trouve_version and trouve_zip then
begin
// isoler le champ version
i:=pos('version ',s2);
@@ -190,7 +191,7 @@ begin
end
else
begin
if notificationVersion then Affiche('Pas d''accès au site CDM rail',clorange);
if notificationVersion then Affiche('Pas d''accès au site CDM rail ou échec téléchargement',clorange);
end;
end;

35
verif_version.~dfm
View File

@@ -1,35 +0,0 @@
object FormVersion: TFormVersion
Left = 500
Top = 341
Width = 468
Height = 194
Caption = 'V'#233'rification de version'
Color = clBtnFace
Font.Charset = ANSI_CHARSET
Font.Color = clBlack
Font.Height = -16
Font.Name = 'Arial Narrow'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 20
object Memo1: TMemo
Left = 16
Top = 32
Width = 425
Height = 105
Font.Charset = ANSI_CHARSET
Font.Color = clBlack
Font.Height = -13
Font.Name = 'Arial Narrow'
Font.Style = []
ParentFont = False
ScrollBars = ssVertical
TabOrder = 0
end
object TimerVerif: TTimer
OnTimer = TimerVerifTimer
end
end

210
verif_version.~pas
View File

@@ -1,210 +0,0 @@
unit verif_version;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls , ComCtrls ,WinInet, ExtCtrls;
type
TFormVersion = class(TForm)
TimerVerif: TTimer;
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure TimerVerifTimer(Sender: TObject);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;
var
FormVersion: TFormVersion;
Lance_verif : integer;
verifVersion,notificationVersion : boolean;
Const Version='2.11'; // sert à la comparaison de la version publiée
implementation
uses UnitPrinc;
{$R *.dfm}
Procedure Aff(s : string);
begin
FormVersion.Memo1.lines.add(s);
end;
function GetCurrentProcessEnvVar(const VariableName: string): string;
var
nSize: DWord;
begin
nSize:=0;
nSize:=GetEnvironmentVariable(PChar(VariableName), nil, nSize);
if nSize=0 then
begin
result:='';
end
else
begin
SetLength(result,nSize-1);
if GetEnvironmentVariable(PChar(VariableName), PChar(result), nSize) <> nSize - 1 then
raise Exception.Create(SysErrorMessage(GetlastError))
end;
end;
// téléchargement d'une page internet sans cache dans un fichier
function DownloadURL_NOCache(aUrl: string;s : string): Boolean;
var
hSession: HINTERNET;
hService: HINTERNET;
Fs:TFileStream;
lpBuffer: array[0..1024 + 1] of byte;
dwBytesRead: DWORD;
dwTimeout : integer;
begin
Result:=False;
DeleteFile(s);
Try Fs:=TFileStream.Create(s,fmCreate,fmShareDenyNone);
hSession:=InternetOpen('MyApp',INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
try
if Assigned(hSession) then
begin
// fonction longue
dwTimeout:=2000; //2s
InternetSetOption(hSession,INTERNET_OPTION_CONNECT_TIMEOUT,@dwTimeOut, SizeOf(dwTimeOut));
hService:=InternetOpenUrl(hSession, PChar(aUrl), nil, 0, INTERNET_FLAG_RELOAD, 0);
if Assigned(hService) then
try
while True do
begin
dwBytesRead:=1024;
InternetReadFile(hService,@lpBuffer,1024,dwBytesRead);
fs.WriteBuffer(lpBuffer,dwBytesRead);
if dwBytesRead=0 then break;
end;
Result:=True;
finally
InternetCloseHandle(hService);
end;
end;
finally
InternetCloseHandle(hSession);
end;
finally
fs.Free;
end;
end;
procedure verifie_version;
var s,s2,s3,Version_p,Url,LocalFile : string;
trouve_version,trouve_zip : boolean;
fichier : text;
i,j,erreur : integer;
V_publie,V_utile : real;
begin
//Affiche('vérifie version',clLime);
if not(AvecInit) then exit ;
if not(verifVersion) then exit;
Url:='http://cdmrail.free.fr/ForumCDR/viewtopic.php?f=77&t=3906#p50499';
LocalFile:='page.txt';
trouve_version:=false;
trouve_zip:=false;
if DownloadURL_NOCache(Url,localFile) then
begin
AssignFile(fichier,LocalFile);
reset(fichier);
while not(eof(fichier)) and (not(trouve_version) or not(trouve_zip)) do
begin
readln(fichier,s);
s:=LowerCase(s);
if not(trouve_version) then
begin
i:=pos('version ',s);
trouve_version:=i<>0;
if trouve_version then s2:=s;
end;
if not(trouve_zip) then
begin
i:=pos('.zip',s);
trouve_zip:=i<>0;
if trouve_zip then s3:=s;
end;
// Aff(s)
end;
closefile(fichier);
if trouve_version then
begin
// isoler le champ version
i:=pos('version ',s2);
delete(s2,1,i+7);
j:=pos(' ',s2);
Version_p:=copy(s2,1,j-1); // version dans version_p
// isoler l'url du zip
i:=pos('href="',s3);
delete(s3,1,i+5);
j:=pos('"',s3);
s3:=copy(s3,1,j-1);
i:=pos('.',s3);
if i<>0 then delete(s3,i,1); // supprimer le .
s3:='http://cdmrail.free.fr/ForumCDR'+s3 ;
aff(s3); // lien dans s3
// changer le . en ,
s:=Version_p;
// i:=pos('.',s);if i<>0 then s[i]:=',';
s2:=version;
// i:=pos('.',s2);if i<>0 then s2[i]:=',';
val(s,V_publie,erreur); if erreur<>0 then exit;
val(s2,V_utile,erreur); if erreur<>0 then exit;
if V_utile<V_publie then
begin
FormVersion.show;
s:='Vous utilisez la version '+version+' mais il existe la version '+Version_p;
Aff(s);
if MessageDlg(s+'. Voulez-vous la télécharger?',mtConfirmation,[mbYes,mbNo],0)=mrYes then
begin
// récupérer depuis la variable d'environnement windows USERPROFILE le repertoire de la session ouverte
s:=GetCurrentProcessEnvVar('USERPROFILE')+'\Downloads\Signaux_Complexes_GL.Zip';
Aff('Téléchargement de '+s3+' dans ');
Aff(s);
if DownloadURL_NOCache(s3,s) then
//if true then
begin
Aff('Téléchargement réussi');
Aff('Vous pouvez ouvrir le dossier de téléchargement, décomprimer le zip et l''installer');
end
else Aff('Echec de téléchargement');
end
else formVersion.Free;
end;
if (V_utile=V_publie) and notificationVersion then Affiche('Votre version '+Version_p+' est à jour',clLime);
end;
end
else
begin
if notificationVersion then Affiche('Pas d''accès au site CDM rail',clorange);
end;
end;
procedure TFormVersion.FormCreate(Sender: TObject);
begin
Timerverif.Interval:=1000; // timer à 1 seconde
Lance_verif:=2; // lancer la vérification de version dans 1s
end;
procedure TFormVersion.TimerVerifTimer(Sender: TObject);
begin
if lance_verif>0 then dec(lance_verif);
if lance_verif=1 then verifie_version;
end;
end.