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

238
UnitConfig.pas
View File

@@ -77,7 +77,6 @@ type
Label15: TLabel; Label15: TLabel;
TabSheetAct: TTabSheet; TabSheetAct: TTabSheet;
Label16: TLabel; Label16: TLabel;
MemoAct: TMemo;
CheckBoxSrvSig: TCheckBox; CheckBoxSrvSig: TCheckBox;
Memo1: TMemo; Memo1: TMemo;
Memo2: TMemo; Memo2: TMemo;
@@ -185,12 +184,12 @@ type
GroupBox15: TGroupBox; GroupBox15: TGroupBox;
EditNbDetDist: TEdit; EditNbDetDist: TEdit;
Label31: TLabel; Label31: TLabel;
RichAct: TRichEdit;
procedure ButtonAppliquerEtFermerClick(Sender: TObject); procedure ButtonAppliquerEtFermerClick(Sender: TObject);
procedure Button2Click(Sender: TObject); procedure Button2Click(Sender: TObject);
procedure FormActivate(Sender: TObject); procedure FormActivate(Sender: TObject);
procedure FormCreate(Sender: TObject); procedure FormCreate(Sender: TObject);
procedure MemoSignauxClick(Sender: TObject); procedure MemoSignauxClick(Sender: TObject);
procedure MemoActClick(Sender: TObject);
procedure PageControlChange(Sender: TObject); procedure PageControlChange(Sender: TObject);
procedure RichAigMouseDown(Sender: TObject; Button: TMouseButton; procedure RichAigMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); Shift: TShiftState; X, Y: Integer);
@@ -213,6 +212,15 @@ type
procedure EditSuiv3Change(Sender: TObject); procedure EditSuiv3Change(Sender: TObject);
procedure EditDet4Change(Sender: TObject); procedure EditDet4Change(Sender: TObject);
procedure EditSuiv4Change(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 private
{ Déclarations privées } { Déclarations privées }
public public
@@ -267,7 +275,7 @@ var temps : integer;
begin begin
if SocketCDM_connecte=false then begin envoi_CDM:=false;exit;end; if SocketCDM_connecte=false then begin envoi_CDM:=false;exit;end;
//Affiche('Envoi à CDM rail',clRed);Affiche(s,ClGreen); //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); Formprinc.ClientSocketCDM.Socket.SendText(s);
// attend l'ack // attend l'ack
ackCDM:=false;nackCDM:=false; ackCDM:=false;nackCDM:=false;
@@ -333,7 +341,7 @@ begin
end; end;
procedure connecte_CDM; procedure connecte_CDM;
var s , ss : string; var s : string;
i : integer; i : integer;
begin begin
// déconnexion de l'ancienne liaison éventuelle // déconnexion de l'ancienne liaison éventuelle
@@ -389,7 +397,7 @@ end;
// teste si une adresse IP V4 est ok // teste si une adresse IP V4 est ok
function Ipok(s : string) : boolean; function Ipok(s : string) : boolean;
var i,k,posp,n,octet,erreur : integer; var i,k,octet,erreur : integer;
begin begin
for k:=1 to 3 do for k:=1 to 3 do
begin begin
@@ -405,7 +413,7 @@ end;
// vérifie si la config de la com série/usb est ok // vérifie si la config de la com série/usb est ok
function config_com(s : string) : boolean; function config_com(s : string) : boolean;
var sa : string; var sa : string;
j,i,erreur : integer; i,erreur : integer;
begin begin
sa:=s; sa:=s;
protocole:=-1; protocole:=-1;
@@ -414,19 +422,15 @@ begin
if i<>0 then if i<>0 then
begin begin
delete(s,1,i); delete(s,1,i);
j:=i;
i:=pos(',',s); i:=pos(',',s);
j:=j+i;
if i<>0 then if i<>0 then
begin begin
delete(s,1,i); delete(s,1,i);
i:=pos(',',s); i:=pos(',',s);
j:=j+i;
if i<>0 then if i<>0 then
begin begin
delete(s,1,i); delete(s,1,i);
i:=pos(',',s); i:=pos(',',s);
j:=j+i;
if i<>0 then if i<>0 then
begin begin
delete(s,1,i); delete(s,1,i);
@@ -564,6 +568,30 @@ begin
encode_sig:=s; encode_sig:=s;
end; 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 // modifie les fichiers de config en fonction du paramétrage
procedure genere_config; procedure genere_config;
var s: string; var s: string;
@@ -1040,7 +1068,10 @@ begin
// actionneurs // actionneurs
for i:=1 to maxTablo_act do 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 PageControl.ActivePage:=TabSheetCDM; // force le premier onglet sur la page
for i:=1 to NbDecodeur do 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; s,s2,ss : string;
trouve : bool; trouve : bool;
begin begin
with formConfig.MemoAct do with formConfig.RichAct do
begin begin
ligne:=Perform(EM_LINEFROMCHAR,-1,0); // numéro de la lignée cliquée 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]); s:=Uppercase(Lines[ligne]);
if s='' then exit; if s='' then exit;
SelStart:=Perform(EM_LINEINDEX,Ligne,0); // début de la sélection SelStart:=Perform(EM_LINEINDEX,Ligne,0); // début de la sélection
@@ -1578,11 +1612,6 @@ begin
Aff_champs_sig; Aff_champs_sig;
end; end;
procedure TFormConfig.MemoActClick(Sender: TObject);
begin
Aff_champs_act;
end;
procedure TFormConfig.PageControlChange(Sender: TObject); procedure TFormConfig.PageControlChange(Sender: TObject);
begin begin
if PageControl.ActivePage=TabSheetAig then if PageControl.ActivePage=TabSheetAig then
@@ -2114,6 +2143,181 @@ begin
end; end;
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. end.

BIN
UnitDebug.dcu
View File

Binary file not shown.

87
UnitDebug.dfm
View File

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

55
UnitDebug.pas
View File

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

BIN
UnitPrinc.dcu
View File

Binary file not shown.

61
UnitPrinc.dfm
View File

@@ -1,6 +1,6 @@
object FormPrinc: TFormPrinc object FormPrinc: TFormPrinc
Left = 12 Left = 1296
Top = 210 Top = 222
Width = 1212 Width = 1212
Height = 664 Height = 664
Caption = 'Client TCP-IP CDM Rail ou USB - syst'#232'me LENZ' Caption = 'Client TCP-IP CDM Rail ou USB - syst'#232'me LENZ'
@@ -1201,24 +1201,6 @@ object FormPrinc: TFormPrinc
Font.Style = [] Font.Style = []
ParentFont = False ParentFont = False
end 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 object ScrollBox1: TScrollBox
Left = 631 Left = 631
Top = 168 Top = 168
@@ -1231,7 +1213,7 @@ object FormPrinc: TFormPrinc
Anchors = [akTop, akRight, akBottom] Anchors = [akTop, akRight, akBottom]
Color = clWhite Color = clWhite
ParentColor = False ParentColor = False
TabOrder = 1 TabOrder = 0
end end
object GroupBox1: TGroupBox object GroupBox1: TGroupBox
Left = 631 Left = 631
@@ -1240,7 +1222,7 @@ object FormPrinc: TFormPrinc
Height = 129 Height = 129
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
Caption = 'Commande d'#39'accessoires' Caption = 'Commande d'#39'accessoires'
TabOrder = 2 TabOrder = 1
object Label2: TLabel object Label2: TLabel
Left = 7 Left = 7
Top = 16 Top = 16
@@ -1339,7 +1321,7 @@ object FormPrinc: TFormPrinc
Width = 281 Width = 281
Height = 129 Height = 129
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
TabOrder = 5 TabOrder = 4
object BoutonRaf: TButton object BoutonRaf: TButton
Left = 8 Left = 8
Top = 8 Top = 8
@@ -1439,7 +1421,7 @@ object FormPrinc: TFormPrinc
Height = 25 Height = 25
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
Caption = 'Panel2' Caption = 'Panel2'
TabOrder = 6 TabOrder = 5
object Label1: TLabel object Label1: TLabel
Left = 16 Left = 16
Top = 4 Top = 4
@@ -1468,7 +1450,26 @@ object FormPrinc: TFormPrinc
Height = 17 Height = 17
Anchors = [akLeft, akRight, akBottom] Anchors = [akLeft, akRight, akBottom]
Caption = 'xx' 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 TabOrder = 7
OnChange = FenRichChange
end end
object Timer1: TTimer object Timer1: TTimer
Interval = 100 Interval = 100
@@ -1499,6 +1500,10 @@ object FormPrinc: TFormPrinc
Caption = 'Etat des aiguillages' Caption = 'Etat des aiguillages'
OnClick = Etatdesaiguillages1Click OnClick = Etatdesaiguillages1Click
end end
object Etatdessignaux1: TMenuItem
Caption = 'Etat des signaux'
OnClick = Etatdessignaux1Click
end
object N3: TMenuItem object N3: TMenuItem
Caption = '-' Caption = '-'
end end
@@ -1611,4 +1616,12 @@ object FormPrinc: TFormPrinc
Left = 888 Left = 888
Top = 16 Top = 16
end end
object PopupMenuFenRich: TPopupMenu
Left = 208
Top = 24
object Copier1: TMenuItem
Caption = 'Copier'
OnClick = Copier1Click
end
end
end end

171
UnitPrinc.pas
View File

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

1609
UnitPrinc.~dfm
View File

File diff suppressed because it is too large Load Diff

1384
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 begin
i:=pos('.zip',s); i:=pos('.zip',s);
trouve_zip:=i<>0; trouve_zip:=i<>0;
if trouve_zip then s3:=s; if trouve_zip then
s3:=s;
end; end;
// Aff(s) // Aff(s)
end; end;
closefile(fichier); closefile(fichier);
if trouve_version then if trouve_version and trouve_zip then
begin begin
// isoler le champ version // isoler le champ version
i:=pos('version ',s2); i:=pos('version ',s2);
@@ -190,7 +191,7 @@ begin
end end
else else
begin 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;
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.