1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
| <HEAD>
<title> Aide au calcul V2.0 </title>
<HTA:APPLICATION
id="CalcModule"
applicationname="CalcModule"
version="2"
MAXIMIZEBUTTON="no"
SCROLL="no"
BORDER = "thin" >
<SCRIPT language="VBScript" type="text/vbscript">ResizeTo 927,196: MoveTo (Screen.Width-927)/2,(Screen.Height - 196) / 2</SCRIPT>
</HEAD>
<SCRIPT language="VBScript" type="text/vbscript">
Option Explicit
' Déclarations utilisables dans toute la partie VBScript
Dim LaFormule()
Dim SelTexte, NbrCaract
Dim posFin, StartSel
Dim DossierDuProg
Dim ScriptCtrl, RegEx
Const Pi = "(4*Atn(1))" 'son équivalence proche
'----------------------------------------------------------------------------------------------------------------------
Sub Window_Onload()
'initialisation
Set ScriptCtrl = CreateObject("ScriptControl")
ScriptCtrl.Language = "vbscript"
Set RegEx = New RegExp
RegEx.IgnoreCase = False 'distingue les lettres minuscule et MAJUSCULE
RegEx.Global = True 'la recherche s'applique à la chaîne entière
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
If WshShell.ExpandEnvironmentStrings("%HOMEDRIVE%") <> Left(WshShell.CurrentDirectory, 2) Then
'DossierDuProg = Left(WshShell.CurrentDirectory, 3) & "Calculateurs\Calcul divers\" ' sur le serveur
DossierDuProg = WshShell.CurrentDirectory & "\" ' sur clef USB
Else
DossierDuProg = WshShell.CurrentDirectory & "\" ' en local
End If
Set WshShell = Nothing
ChargeFormules
txtDebug.Style.display = "none": : BtRefresh.Style.display = "none" 'ne sera visible que s'il se produit une erreur
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub Window_OnUnload()
Set ScriptCtrl = Nothing
Set RegEx = Nothing
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub ChargeFormules()
Dim FSO, LeFichier, PourTbl
Set FSO = CreateObject("Scripting.FileSystemObject")
Set LeFichier = FSO.OpenTextFile(DossierDuProg & "FichierArray.txt",1)
PourTbl = LeFichier.ReadAll: LeFichier.Close
Set FSO = Nothing
Dim MeTbl, ChampS, T, U
MeTbl = split(PourTbl,vbNewLine)
Dim oOption
'vide la liste LstFormules (pour rafraichissement Ajout/suppression dans le fichier FichierArray.txt)
For T = LstFormules.length To 0 Step -1: LstFormules.Remove(T): Next
U = 0
For T = 2 To UBound(MeTbl)
Set oOption = window.Document.createElement("OPTION")
ChampS = split(MeTbl(T),"=")
If ChampS(2) = " " Then 'ligne vierge ou titre
If ChampS(3) = "" Then oOption.Value = "": oOption.Text = "" 'ligne vierge
If ChampS(3) <> "" Then oOption.Value = "": oOption.Text = ChampS(3) 'Titre ensemble de formules de la ligne Select
End If
If ChampS(1) = " " And ChampS(2) <> " " Then oOption.Value = ChampS(2): oOption.Text = ChampS(3) 'Formule intrinseque
If ChampS(0) <> " " Then
oOption.Value = ChampS(2): oOption.Text = ChampS(3) 'Formule dérivée
U = U + 1 'pour pouvoir dimensionner le tableau formules dérivées
End If
LstFormules.Add (oOption)
Next
Set oOption = Nothing
Redim LaFormule(U,2)
U = -1
For T = 2 To UBound(MeTbl)
ChampS = split(MeTbl(T),"=")
If ChampS(0) <> " " Then U = U + 1: LaFormule(U,0) = ChampS(0): LaFormule(U,1) = ChampS(1) 'Ligne de formule derivée
Next
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub LstFormules_onmouseover()
Dim Docu, SelectioneR
Set Docu = window.document
Set SelectioneR = Docu.selection.createRange()
If Docu.activeElement.Id = "txtEnoncer" Then
SelTexte = SelectioneR.Text
NbrCaract = Len(SelTexte)
StartSel = 1 ' pourquoi 1 ??? Mystère ......, trouvé .........>, La valeur de StartSel depant de l'endroit dans le code ou est déclaré le conteneur TEXTAREA ou <INPUT TYPE="text"
While SelectioneR.Move("character", -1): StartSel = StartSel + 1: Wend
txtDebug.Value = "texte selectionné: " & SelTexte & " " & "Nbre de caractere: " & NbrCaract & " " & "Debut de la selection: " & StartSel
End If
Set SelectioneR = Nothing : Set Docu = Nothing
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub LstFormules_onChange()
Call CreateObject("htmlfile").ParentWindow.ClipboardData.SetData("text", LstFormules.Value)
Dim StrtxtEnoncer, StrDeb, StrFor, StrFin
StrtxtEnoncer = txtEnoncer.Value
StrFor = LstFormules.Value 'récupération de l'énoncé de la formule choisis
If SelTexte = "" Then
'insère au niveau du curseur
If StartSel > 1 Then StrDeb = Left(StrtxtEnoncer, StartSel - 1)
If StartSel < Len(StrtxtEnoncer) Then StrFin = Right(StrtxtEnoncer, Len(StrtxtEnoncer) - StartSel + 1)
If StartSel = 1 Then StrFin = StrtxtEnoncer
Else
'insère au niveau du curseur en incluant la sélection
If StrFor <> "LogN(x,n)" Then
StrFor = Replace(StrFor, "x", SelTexte)
Else
StrFor = Replace(StrFor, "x,n", SelTexte)
End If
If StartSel > 1 Then
StrDeb = Left(StrtxtEnoncer, StartSel - 1)
If StartSel + NbrCaract < Len(StrtxtEnoncer) Then StrFin = Right(StrtxtEnoncer, (Len(StrtxtEnoncer) - (StartSel + Len(SelTexte)) + 1))
End If
If StartSel = 1 Then
If NbrCaract < Len(StrtxtEnoncer) Then StrFin = Right(StrtxtEnoncer, Len(StrtxtEnoncer) - Len(SelTexte))
End If
End If
txtEnoncer.Value = StrDeb & StrFor & StrFin
SelTexte = "": StartSel = 0: NbrCaract = 0
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub BtGo_onClick()
txtDebug.Style.display = "none"
Dim Matches
Dim Cpt, PosDeb
Dim StrFortmater, Transf
Dim Enoncer, X, Colonne
StrFortmater = Trim(txtEnoncer.Value)
For Cpt = 0 To UBound(LaFormule)
if LaFormule(Cpt, 0) = "" then exit for
RegEx.Pattern = "\b" & LaFormule(Cpt, 0) & "\b" 'mot entier avec respect des lettres minuscules et MAJUSCULES
Do While RegEx.Test(StrFortmater) = True
Set Matches = RegEx.Execute(StrFortmater)
PosDeb = Matches.Item(0).FirstIndex + 1
X = RecupF(StrFortmater, PosDeb + Matches.Item(0).Length)
Enoncer = Mid(StrFortmater, PosDeb, posFin - PosDeb)
If LaFormule(Cpt, 0) <> "LogN" Then
Transf = Replace(LaFormule(Cpt, 1), "X", X)
Else
If Instr(X,",") = 0 Then
txtDebug.Value = "Nombre d'arguments ou affectation de propriété incorrects: " & Chr(34) & "Log" & Chr(34)
txtDebug.Style.display = ""
Exit Sub
End If
Colonne = Split(X, ",")
Transf = Replace(LaFormule(Cpt, 1), "X", Colonne(0))
Transf = Replace(Transf, "N", Colonne(1))
End If
Transf = "(" & Transf & ")" 'pour faire considérer à ScriptCtrl.Eval qu'il doit calculer l'ensemble de la fonction
StrFortmater = Replace(StrFortmater, Enoncer, Transf, 1, 1, vbTextCompare)
Loop
Next
'gérer le remplacement du literal Pi par son équivalence proche 4 * Atn(1)
StrFortmater = Replace(StrFortmater, "Pi", Pi, 1, -1, vbTextCompare)
'gérer le remplacement de la virgule séparateur décimale littéral par le séparateur décimale mathématique point
StrFortmater = Replace(StrFortmater, ",", ".", 1, -1, vbTextCompare)
txtFormater.Value = StrFortmater
On Error Resume Next
txtResult.Value = ""
txtResult.Value = ScriptCtrl.Eval(StrFortmater)
'__________________ petite gestion d'erreur '__________________
If ScriptCtrl.Error.Number <> 0 Then
Err.Clear
If chkAide.Checked = True Then txtDebug.Value = ScriptCtrl.Error.Description: txtDebug.Style.display = ""
Else
If txtResult.Value = "" Then
If chkAide.Checked = True Then txtDebug.Value = "Impossible d'évaluer votre ligne de calcul": txtDebug.Style.display = ""
End If
End If
Set Matches = Nothing
End Sub
'----------------------------------------------------------------------------------------------------------------------
Function RecupF(DansStr, Start)
Dim Ov, Fr, T
'compter les ( avec Ov, et en même temps les ), quand il y a égalité, la formule est complète, le dernier ) est égal à posFin
For T = Start To Len(DansStr)
If Mid(DansStr, T, 1) = "(" Then Ov = Ov + 1
If Mid(DansStr, T, 1) = ")" Then Fr = Fr + 1
If Ov = Fr And Ov <> 0 Then
posFin = T + 1
RecupF = Mid(DansStr, Start + 1, T - (Start + 1)): Exit For
End If
Next
End Function
'----------------------------------------------------'pour débuguer par le créateur de l'.HTA-------------------------
Sub Masque_ondblclick()
If txtDebug.Style.display = "" Then
txtDebug.Style.display = "none": BtRefresh.Style.display = "none"
Else
txtDebug.Style.display = "": BtRefresh.Style.display = ""
End If
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub BtRefresh_onClick()
ChargeFormules
End Sub
</SCRIPT>
<body style="font-family:Courier New; Arial, MS Sans Serif, Verdana, serif; font-size=14px; font-weight:bold; background-color: #3D6381">
<Div Name="Masque" Id="Masque" style="color:#FFFFFF; position:absolute; left:8px; top:20px; height:22px; width:150px"> Enoncé du calcul </Div>
<SELECT name="LstFormules" Id="LstFormules" title="Insert ou englobe la sélection dans l'énoncé"
style="position: absolute; left: 240px; top: 8px; height:22px; width:327px"> </SELECT>
<Div style="color:#FFFFFF; position:absolute; left:572px; top:10px; height:22px; width:160px" > Raccourcis formules </Div>
<INPUT TYPE="CheckBox" NAME="chkAide" Id="chkAide" title="En cas d'erreur afficher un message" CHECKED
style="background-color: #3D6381; border-style: solid; position: absolute; left:885px; top:8px; height:21px; width:21px" >
<INPUT TYPE="text" name="txtEnoncer" Id="txtEnoncer" Value =""
style="background-color: #D2FFC2; border-style: solid; position: absolute; left:4px; top:36px; height:21px; width:905px; font-family:Courier New; Arial, MS Sans Serif, Verdana, serif">
<Div style="color:#FFFFFF; position:absolute; left:8px; top:60px; height:22px; width:400px" > Enoncé reformaté (détails des formules dérivées) </Div>
<TEXTAREA name="txtFormater" Id="txtFormater" Value ="" Rows="2" COLS="40"
style="background-color: #FFFFB3; border-style: solid; position: absolute; left:4px; top:76px; height:42px; width:905px; font-family:Courier New; Arial, MS Sans Serif, Verdana, serif"></TEXTAREA>
<INPUT Type="button" name="BtGo" Id="BtGo" value="Go"
style="position: absolute; left: 5px; top: 124px; height:28px; width:41px" >
<Div style="color:#FFFFFF; position:absolute; left:70px; top:131px; height:22px; width:56px" > Résultat </Div>
<INPUT TYPE="text" name="txtResult" Id="txtResult" Value =""
style="background-color: #FFFFFF; border-style: solid; position: absolute; left:136px; top:129px; height:21px; width:213px" >
<INPUT TYPE="text" NAME="txtDebug" id="txtDebug" VALUE="Pour débuguer"
style="color:#FF0000; border-style:solid; position:absolute; left:360px; top:129px; height:21px; width:550px" >
<INPUT Type="button" name="BtRefresh" Id="BtRefresh" value="Actualiser liste formules"
style="position: absolute; left: 5px; top: 4px; height:20px; width:150px" >
</body> |
[HTA] Aide à l’énoncé d’un calcul
HArccos(10)+Arccotan(5) = (Log(10+Sqr(10*10-1)))+(Atn(5)+2*Atn(1))
Envoyé par FichierArray.txt
(restons optimiste
) , impossible de sélectionné 2 fois de suite la même formule, si quelqu'un saurait quel événement On_Quoi utiliser
.
Répondre avec citation
Partager