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
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
| <HTML>
<HEAD>
<TITLE> Outils DVP </TITLE>
<HTA:APPLICATION
ID = "OutilsDVPnew"
APPLICATIONNAME="OutilsDVPnew"
VERSION="4.5"
MAXIMIZEBUTTON="no"
SCROLL="no"
BORDER = "thin"
ICON = "OutilPersoV.ico"
>
</HEAD>
<!-- ------------------------------------------------------------------------------------------------------------------------------ -->
<SCRIPT language="VBScript">
'Déclarations utilisables dans toute la partie VBScript
Option Explicit
Dim MeWidth, MeHeight, MeTop, MeLeft, BarT, Cadr
Dim DossierRacineDuProg, T, ParamPseudo()
Dim MasqueRoue, FinDuOleDrop, Excel
Dim Xdiv, StartSel
'----------------------------------------------------------------------------------------------------------------------
Sub Window_Onload()
Dim ChemNomComplet
ChemNomComplet = OutilsDVPnew.CommandLine ' ChemNomComplet = Id du programme.CommandLine
DossierRacineDuProg = Left(ChemNomComplet, (InStrRev(ChemNomComplet, "\", -1, vbTextCompare)))
DossierRacineDuProg = Replace(DossierRacineDuProg,Chr(34),"")
Xdiv = 0 ' permet de détecter le RE-chargement de la liste parametres
MoveTo -Screen.availWidth,-Screen.availHeight 'place la page HTA hors de l'écran
ResizeTo Screen.availWidth,Screen.availHeight ' Agrandi la page HTA au maximum de la grandeur disponible du bureau
'utilisé dans la sub OptionPremierPlan
Cadr = screenLeft + Screen.availWidth ' Calcul de l'épaisseur du cadre de la fenêtre HTA
BarT = (screenTop + Screen.availHeight) - Cadr ' Calcul de la hauteur de la barre de titre de la fenêtre HTA
MeHeight = 356: MeWidth = 288
BtRefresch_onClick
MeTop = (Screen.availHeight - MeHeight) / 2: MeLeft = (Screen.availWidth-MeWidth)/2
MoveTo MeLeft, MeTop ' Centrage de la fenêtre HTA sur le bureau
On Error Resume Next
Set Excel = CreateObject("Excel.Application")
If Err Then Choix.Style.Display = "none" 'Rendre invisible le checkBox donnant la possibilité de mise au premier plan
On Error GoTo 0
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub Window_onUnLoad
Set Excel = NotHing 'nettoyage, même si l'objet Excel n'était pas disponnible
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub BtParams_onClick() 'ouverture et affichage dans Notepad du fichier
Dim WSH, WshProcess
Set WSH = CreateObject("Wscript.shell")
Set WshProcess = WSH.Environment("Process")
Call WSH.Run(WshProcess("WINDIR") & "\notepad.exe " & DossierRacineDuProg & "ParamNews.txt",1,False)
If Err Then MsgBox "n° " & Err.Number & vbnewline & "Description:" & vbnewline & Err.Description
Set WshProcess= nothing: Set WSH= nothing
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub BtRefresch_onClick() 'chargement/rechargement pour la liste LstPhrases et les DIVs liste images Smileys
ResizeTo 200, 30 ' dimensionnement réduit de la fenêtre HTA (largeur, hauteur)
Dim FSO, LeFichier, PourTbl
Set FSO = CreateObject("Scripting.FileSystemObject")
Set LeFichier = FSO.OpenTextFile(DossierRacineDuProg & "ParamNews.txt",1)
PourTbl = LeFichier.ReadAll: LeFichier.Close
Set FSO = Nothing: Set LeFichier = Nothing
Dim ObjDiv, CoulExiste, V, W, X
Dim oOption, MeTbl, ChampS, U, Urll
MeTbl = split(PourTbl,vbNewLine)
Urll = "https://www.developpez.net/forums/images/smilies/" ' chemin dosier pour le chargement des smilies
If Xdiv <> 0 Then 'rechargement de la liste
LstPhrases.length = 0 'vide la liste LstPhrases
Erase ParamPseudo 'vide le tableau et libère la mémoire utilisée
divicons_onmouseover ' aggrandir la DIV sinon le rechargement des Smileys ne se calle pas bien à gauche
divicons.innerHTML = "" 'vide la liste de DIVs des Smileys de la DIV divicons
End If
U = 0: V = 0: X = 0: Xdiv = 0
For T = LBound(MeTbl)+1 To UBound(MeTbl) 'LBound(MeTbl)+1, plus 1 car la 1er ligne du fichier est le descriptif de chaque colonne, donc on ne la lit pas
ChampS = split(MeTbl(T),"|")
If ChampS(2) = "STOP" Then Exit For ' d'ou la necessité d'avoir la liste de smilies en fin de liste du fichier parametres
If ChampS(2) <> "ICONS" Then Set oOption = window.Document.createElement("OPTION")
'Else
'Set oOption = window.Document.createElement("OPTION")
'End If
Select Case ChampS(2) '
'++++++++++++++++++++++ ligne couleur suivant le statut du forumeur +++++++++++++++++++++++
Case "***"
CoulExiste = False
If V <> 0 Then 'verification si la couleur n'est pas dèjà connue
Set ObjDiv = document.GetElementsByTagName("DIV")
For W = 0 To ObjDiv.length - 1
If Instr(1,ObjDiv(W).Id,"Couleur",vbTextCompare) Then
If Lcase(ObjDiv(W).Style.background) = Lcase(ChampS(1)) Then CoulExiste = True: Exit For
End If
Next
End If
Set ObjDiv = Nothing
If CoulExiste = False Then 'création de boites de couleur pour eventuellement modifier la couleur d'un pseudo
Set ObjDiv = window.Document.createElement("DIV")
ObjDiv.Id = "Couleur" & V
ObjDiv.title = "Dbl.click pour modifier la couleur du" & vbnewline & "pseudo actuellement sélectionner"
ObjDiv.Style.position="absolute"
ObjDiv.Style.fontSize="6"
ObjDiv.Style.left="2"
ObjDiv.Style.width="14"
ObjDiv.Style.height="8"
ObjDiv.Style.top= 20 + ((V+1)*10)
ObjDiv.Style.background = cstr(ChampS(1))
ObjDiv.attachevent "ondblclick", GetRef("Modifier_ondblclick")
Document.body.appendChild(ObjDiv)
Set ObjDiv = Nothing
V = V + 1
End If
Redim Preserve ParamPseudo(U)
ParamPseudo(U) = ChampS(0) & "|" & ChampS(1)
U = U + 1
'++++++++++++++++++++ LstPhrases ++++++++++++++++++++++
Case "LIEN" 'ligne à taguer avec l'URL
oOption.Text = ChampS(0): oOption.Value = "" & ChampS(0) & ""
LstPhrases.Add (oOption)
Case "TITRE", "PHRASE", "BALISES"
oOption.text = ChampS(0): oOption.Value = ChampS(1)
LstPhrases.Add (oOption)
'+++++++++++++++++ les DIVs liste images Smileys +++++++++
Case "ICONS"
Set ObjDiv = window.Document.createElement("DIV")
ObjDiv.Id = "Img" & Xdiv
ObjDiv.title = ChampS(0)
ObjDiv.Style.width="236px"
ObjDiv.Style.height="auto"
'la div contient une image dont la source est sur DVP (Champs(1))
LeFichier = "<img src=" & Chr(34) & Urll & Champs(1) & Chr(34) & _
" title=" & Chr(34) & ObjDiv.title & Chr(34) & "><hr>"
ObjDiv.innerHTML = LeFichier
ObjDiv.attachevent "onmouseup", GetRef("ChargeInfo") 'pour que la div repond à l'evenement onmouseup
divicons.appendChild(ObjDiv)
Set ObjDiv = Nothing
Xdiv = Xdiv + 1
End Select
Next
Set oOption = Nothing
divicons_onmouseout ' replacer la DIV reduite dans le coin droit, utile si c'est un rechargement
TextMemo.innertext =""
ResizeTo MeWidth, MeHeight ' dimensionnement normal de la fenêtre HTA (largeur, hauteur)
TextMemo.focus()
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub ChargeInfo(Obj) 'suite au mouseup sur une DIV image Smiley
dim MeObj
set MeObj = Obj.srcElement
ActuTextMemo MeObj.title
divicons_onmouseout 'pour replier la liste images Smileys
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub DetecteSelStart()
'procedure pour trouver ou est le curseur parmis le texte contenu dans TEXTAREA ''TextMemo''
If Not XOption(2).CHECKED Then exit sub 'pas en phase de demande ''Inserer''
TextMemo.focus()
'dim ObjSel
'set ObjSel = TextMemo.createtextRange()
'msgbox ObjSel.htmlText
Dim SelectioneR
Set SelectioneR = window.document.selection.createRange()
'**************************** pour debug *****************
'Dim SelTexte, NbrCaract '*
'SelTexte = SelectioneR.Text: NbrCaract = Len(SelTexte) '*
'************************** fin pour debug ***************
StartSel = -63 + (-Xdiv*4) 'POURQUOI ????????
'pas compris mais, je sais que c'est influencé suivant ou est déclaré l'objet TEXTAREA dans le code dans la partie <Body> .... </body>
'les lignes vierges et/ou les commantaires n'influencent pas, vue la plasse déclaré de TEXTAREA il que StartSel = -63
'par contre, le nombre de smilies chargés, pour chacun il faut ajouter encor -4 à StartSel
While SelectioneR.Move("character", -1): StartSel = StartSel + 1: Wend
' ou pour un même resultat
'While SelectioneR.moveStart("character", -1): StartSel = StartSel + 1: Wend
'******************************************************************* pour debug *******************************************************
'msgbox "texte selectionné: " & SelTexte & " " & "Nbre de caractere: " & NbrCaract & " " & "Debut de la selection: " & StartSel '*
'************************** fin pour debug ********************************************************************************************
Set SelectioneR = Nothing
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub XOption_onclick()
If XOption(2).CHECKED Then DetecteSelStart()
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub ActuTextMemo(Quoi)
'suite au mouse Up sur la liste LstPseudo ou LstPhrases ou sur un Smiley
If XOption(0).CHECKED Then TextMemo.innerHTML = TextMemo.innerHTML & Quoi 'Ajouter
If XOption(1).CHECKED Then TextMemo.innerHTML = Quoi 'Remplacer
If XOption(2).CHECKED Then 'Inserer
Dim StrDeb, StrFin
'msgbox "StartSel=" & StartSel & " len(TextMemo.innertext)=" & len(TextMemo.innerHTML)
If StartSel > len(TextMemo.innerHTML) Then
'insertion apres un retour à la ligne
StrFin = Quoi: Quoi = vbNewLine
StrDeb = Left(TextMemo.innerHTML, StartSel-1)
Else
StrFin = right(TextMemo.innerHTML, len(TextMemo.innerHTML)-StartSel)
StrDeb = Left(TextMemo.innerHTML, StartSel)
End If
TextMemo.innertext = StrDeb & Quoi & StrFin
End If
'pour chaque changement du contenu de TextMemo, fait un copier dans le presse papier system
Call CreateObject("htmlfile").ParentWindow.ClipboardData.SetData("text", TextMemo.innertext)
End sub
'----------------------------------------------------------------------------------------------------------------------
Sub divicons_onmouseover() 'deplier le divicons
'L'événement mouseover est déclenché lorsqu'un dispositif de pointage passe au dessus
'd'un élément lié à l'écouteur d'événement ou au dessus de l'un de ses enfants
divicons.style.width="268px": divicons.style.height="173px": divicons.style.left="0px"
divicons.focus() 'pour masquer le curseur s'il se trouvait sur le TextMemo
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub divicons_onmouseout() 'la souris quitte l'objet, replier le divicons
divicons.style.width="19px": divicons.style.height="17px": divicons.style.left="247px"
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub Modifier_ondblclick(Obj) 'Changement de couleur du pseudo
If LstPseudo.selectedIndex = -1 then Exit Sub
Dim MeObj, OldCouleur, NewCouleur
set MeObj = Obj.srcElement
NewCouleur = Lcase(MeObj.Style.background)
set MeObj = Nothing
OldCouleur = Mid(LstPseudo(LstPseudo.selectedIndex).value, 8, 7)
LstPseudo(LstPseudo.selectedIndex).value = Replace(LstPseudo(LstPseudo.selectedIndex).value, OldCouleur, NewCouleur)
LstPseudo_onchange
End Sub
'---------------------------------------------------------------------------------------------------------------------
Sub BtSupList_onClick() ' supprimer un pseudo de la liste
If TextPseudo.innertext = "" Then Exit Sub
For T = 0 To LstPseudo.length - 1
If LstPseudo(T).innertext = TextPseudo.innertext Then LstPseudo.Remove(T): TextPseudo.innertext = "": Exit For
Next
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub LstPhrases_onmouseup()
MasqueRoue = False
'Pour réutiliser une phrase dèjà en cours de selection dans le ComboBox/listbox avec bouton droit
If window.event.button = 2 then LstPhrases_onChange
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub LstPhrases_onmousewheel()
'Pour bloquer l'événement LstPhrases_onChange si la roue est tournée sur le ComboBox/listbox
'permet de choisir une phrase, puis de cliquer avec le bouton droit sans avoir forcement développé la liste
MasqueRoue = True
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub LstPhrases_onchange() 'inscrit le cette nouvelle phrase dans TextMemo en la formatant
If MasqueRoue = True then Exit Sub 'quitte si l'événement LstPhrases_onmousewheel est l'evenement source
If InsTr(1,LstPhrases.Value,"Titre",vbTextCompare) Then Exit Sub ' quitte l'action si le click est fait sur un separateur
ActuTextMemo LstPhrases.Value
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub LstPseudo_onmouseup()
MasqueRoue = False
'Pour réutiliser un pseudo dèjà en cours de selection dans le ComboBox/listbox avec bouton droit
If window.event.button = 2 then LstPseudo_onChange
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub LstPseudo_onmousewheel()
'Pour bloquer l'événement LstPseudo_onChange si la roue est tournée sur le ComboBox/listbox
'permet de choisir un pseudo, puis de cliquer avec le bouton droit sans avoir forcement développé la liste
MasqueRoue = True
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub LstPseudo_onchange()
'inscrit le nouveau choix de forumeur dans TextMemo
If MasqueRoue = True then Exit Sub 'quitte si l'événement LstPseudo_onmousewheel est l'evenement source
If LstPseudo.Value = "" Then Exit Sub
ActuTextMemo LstPseudo.Value
TextPseudo.Style.Color = Mid(LstPseudo.Value, 9, 6)
TextPseudo.innertext = Mid(LstPseudo.Value, 19, Len(LstPseudo.Value) - 30)
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub TextPseudo_ondrop()
'Exclusivement pour un dragdrop provenant de DVP, ce produit au moment du mouseup du dragdrop
FinDuOleDrop = true
End Sub
'----------------------------------------------------------------------------------------------------------------------
Function VerifExistePseudo(Pseudo)
VerifExistePseudo = False
For T = 0 To LstPseudo.length - 1
If InsTr(1,LstPseudo(T).innertext,Pseudo,vbTextCompare) Then
'Doublon, ce pseudo est déjà dans la liste
TextPseudo.Style.Color = "#FF00FF"
TextPseudo.innertext = "Déjà dans la liste"
VerifExistePseudo = True
Exit Function
End If
Next
End Function
'----------------------------------------------------------------------------------------------------------------------
Function Hex2(Valeur)
'la fonction renvoie la valeur formatée sur 2 caractères
If Len(CStr(Valeur)) = 1 Then Hex2 = "0" & CStr(Valeur) Else Hex2 = CStr(Valeur)
End Function
'----------------------------------------------------------------------------------------------------------------------
Sub TextPseudo_onselect() ' récupération du dragdrop déposé
If FinDuOleDrop = True Then
FinDuOleDrop = False
Dim MsG, TblRecup, TblStatut, oOption, RecupTxt, Coul
Dim SelectioneR
Set SelectioneR = window.document.selection.createRange()
MsG = Trim(SelectioneR.Text) ' récupération du texte dragdrop déposé
Set SelectioneR = Nothing
If Left(MsG,2) = vbNewLine Then MsG = Right(MsG, Len(Msg)- 2)
If MsG = "" Then TextPseudo.innertext = "": MsgBox "Mauvaise récupération pseudo", vbCritical, "Infos": Exit Sub
' Exemple du conternu de MsG
'suite de mouse down sur le pseudo suivit du deplacement et pose sur le TextPseudo
' https://www.developpez.net/forums/u51625/progelect/
' ----------------------- ou --------------------------
'suite à la selection du pseudo et statut, puis moouse down suivit du deplacement et pose sur le TextPseudo
'Sous FireFox
' ProgElecT
' ProgElecT est actuellement connecté
' Rédacteur/Modérateur
'Sous Chrome
' ProgElecT ProgElecT est actuellement connecté
' Rédacteur/Modérateur
'Sous Edge
' ProgElecT
' Rédacteur/Modérateur
'Sous Intetrnet Explorer
' ProgElecT
' 6 ou 7 retour à la ligne
' Rédacteur/Modérateur
If InsTr(1,MsG,"www.developpez.net/forums/U",vbTextCompare) Then 'MsG = https://www.developpez.net/forums/u51625/progelect/
RecupTxt = left(MsG,Len(MsG)-1) 'https://www.developpez.net/forums/u51625/progelect
RecupTxt = StrReverse(RecupTxt) 'tcelegorp/52615/smurof/ten.zeppoleved.www//:sptth
T = InsTr(1,RecupTxt,"/",vbTextCompare)
RecupTxt = Left(RecupTxt,T-1) 'tcelegorp
RecupTxt = StrReverse(RecupTxt) 'progelect, RecupTxt est le pseudo sans le/les eventuelles majuscules
Else
TblRecup = split(MsG,vbNewLine)
'TextMemo.innertext = UBound(TblRecup)& vbnewline & MsG
'************************* Adaptation suivant le navigateur *********************
If UBound(TblRecup) = 1 Then 'sous Chrome ou Edge mais aussi sous FireFox suivant l'endroit du dragdrop
MsG = Replace(MsG," ",vbNewLine,1,1,vbTextCompare)
MsG = Replace(MsG," ",vbNewLine,1,1,vbTextCompare)
TblRecup = split(MsG,vbNewLine)
End If
If UBound(TblRecup) > 2 Then 'sous Intetrnet Explorer
MsG = TblRecup(0) & vbNewLine & Trim(TblRecup(UBound(TblRecup)-1)) & vbNewLine & TblRecup(UBound(TblRecup))
TblRecup = split(MsG,vbNewLine)
End If
'********************* Fin Adaptation suivant le navigateur *********************
If UBound(TblRecup) <> 2 Then TextPseudo.innertext = "": MsgBox "Mauvaise récupération du pseudo et/ou statut du Forumeur", vbCritical, "Infos": Exit Sub
RecupTxt = TblRecup(0) '
End if
If VerifExistePseudo(RecupTxt) = True Then 'Doublon, ce pseudo est déjà dans la liste
TextPseudo.Style.Color = "#FF00FF"
TextPseudo.innertext = "Déjà dans la liste"
Exit Sub
End If
If InsTr(1,MsG,"www.developpez.net/forums/U",vbTextCompare) Then
' connection à la page profil du forumeur
Dim IE, Doc, Helem, ElemClasName, RecupTxtHTML, U
Set IE = CreateObject("InternetExplorer.Application")
IE.navigate MsG
Do While IE.readyState <> 4: Loop
Set Doc = IE.document
Set Helem = Doc.getElementById("userinfo")
Set ElemClasName = Helem.getElementsByClassName("member_username")
RecupTxtHTML = ElemClasName(0).innerHTML
' <span style="color:rgb(0,141,0); text-decoration:underline;">ProgElecT</span>
' ou si forumeur lambda
' le pseudo
RecupTxt = ElemClasName(0).innertext ' ProgElecT, (le pseudo quelque soit le statut du forumeur)
IE.Quit
Set ElemClasName = Nothing: Set Helem = Nothing: Set Doc = Nothing:Set IE = Nothing
TextPseudo.innertext = RecupTxt
T = InsTr(1,RecupTxtHTML,"color: ",vbTextCompare)
If T >1 Then ' recuperation de la couleur
T = T + 7: U = InsTr(1,RecupTxtHTML,")",vbTextCompare)+1
Coul = mid(RecupTxtHTML,T,U-T) ' rgb(223,112,0) ou rgb(0,141,0) ou ......
Coul = Replace(coul,"rgb(","") ' 223,112,0) ou 0,141,0) ou ......
Coul = Replace(coul,")","") ' 223,112,0 ou 0,141,0 ou .....
Dim TblCoul
TblCoul = Split(Coul,",")
Coul = "#" & Hex2(Hex(TblCoul(0))) & Hex2(Hex(TblCoul(1))) & Hex2(Hex(TblCoul(2))) ' #DF7000 ou #008D00 ou .....
TextPseudo.Style.Color = Coul
Else ' un forumeur lambda n'a pas de couleur renseigné
'récupération de la couleur correspondant au statut du posteur provenant du fichier ParamNews
TblStatut = split(ParamPseudo(0),"|")
TextPseudo.Style.Color = TblStatut(1) 'couleur du fichier ParamNews "#22229C"
End If
Else
'récupération de la couleur correspondant au statut du posteur provenant du fichier ParamNews
For T = 0 To UBound(ParamPseudo)
TblStatut = split(ParamPseudo(T),"|")
'TblRecup(2) = Statut du pseudo du OleDrag et TblStatut(0) = Statut du pseudo du fichier ParamNews
If TblRecup(2) = TblStatut(0) Then Exit For ' correspondance trouvée
Next
If T > UBound(ParamPseudo) Then TblStatut = split(ParamPseudo(0),"|") ' pas de correspondance donc considéré comme posteur lambda
TextPseudo.Style.Color = TblStatut(1) 'couleur du fichier ParamNews
TextPseudo.innertext = TblRecup(0) ' Nom du pseudo du OleDrag
End If
Set oOption = window.Document.createElement("OPTION")
oOption.Text = TextPseudo.innertext ' innertext = Nom du pseudo du OleDrag apparessant dans la liste
'Value, n'apparait pas dans la liste mais, pour cette index de la liste, permet de memorisé la phrase qui formaterat l'infos
oOption.Value = "[COLOR=" & TextPseudo.Style.Color & "]" & TextPseudo.innertext & ""[/COLOR]
LstPseudo.Add (oOption) ' ajout à la liste
Set oOption = Nothing
End If
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub TextMemo_ondragstart() ' pour enpêcher le déposé de TextMemo vers TextPseudo
TextPseudo.readOnly = True
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub TextMemo_ondragend() ' pour réstituer un posé possible sur TextPseudo
TextPseudo.readOnly = False
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub OptionPremierPlan() 'N'est actif que si EXCEL est disponnible sur l'ordinateur
Dim RedactionAPI, Mehwnd, MeTilte, Profondeur, MeFlags
'Constantes pour l'API -- SetWindowPos --
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40
MeTilte = Document.TITLE '<TITLE> Titre de la fenêtre du programme </TITLE>
'rédaction de la requête à passer à Excel.ExecuteExcel4Macror, pour récupération du Handle du présent programme
RedactionAPI = "CALL(""user32"",""FindWindowA"",""JFF"",""HTML Application Host Window Class"",""" & MeTilte & """)"
Mehwnd = Excel.ExecuteExcel4Macro(RedactionAPI)
If TypeName(Mehwnd) = "Error" Then
MsgBox "Mehwnd=" & TypeName(Mehwnd), vbCritical, "Recuperation du Handle"
Exit Sub
End If
'actualiser pour le paramétrage de la fonction premier plan ou non, la fenêtre ayant put être agrandie et/ou déplacée
MeLeft = screenLeft - Cadr
MeTop = screenTop - (BarT + Cadr)
MeHeight = document.body.offsetHeight + BarT + (Cadr*2)
MeWidth = document.body.offsetWidth + (Cadr*2)
MeFlags = SWP_NOACTIVATE Or SWP_SHOWWINDOW
'Mise au premier plan ou inversement (bascule)
If Choix.Checked Then Profondeur = HWND_TOPMOST Else Profondeur = HWND_NOTOPMOST
'rédaction de la requête à passer à Excel.ExecuteExcel4Macror, pour mise ou non au premier plan du présent programme
RedactionAPI = "CALL(""user32"",""SetWindowPos"",""JJJJJJJJ"",""" & _
Mehwnd & """,""" & _
Profondeur & """,""" & _
MeLeft & """,""" & _
MeTop & """,""" & _
MeWidth & """,""" & _
MeHeight & """,""" & _
MeFlags & """)"
Mehwnd = Excel.ExecuteExcel4Macro(RedactionAPI)
If TypeName(Mehwnd) = "Error" Then
MsgBox "Mehwnd=" & TypeName(Mehwnd), vbCritical, "Mise ou non au premier plan"
End If
End Sub
</SCRIPT>
<!-- ------------------------------------------------------------------------------------------------------------------------------ -->
<body style="font-family:MS Sans Serif, Arial, Verdana, serif; font-size=10px; font-weight:bold; background-color:#C2E1FF" >
<Input Type="checkbox" name="Choix" id="Choix" Title="Mettre au premier plan" OnClick="OptionPremierPlan"
Style="position:absolute; left:-2px; top:-2px; height:20px; width:20px; background-color:red;" >
<!-- Partie prés formatage couleur du Pseudo ------------------------------------------------------------------------- -->
<Input Type="button" name="BtParams" id="BtParams" Value="Ouvrir le fichier Params"
style="position:absolute; left:18px; top:0px; height:22px; width:130px;
font-family:MS Sans Serif, Arial, Verdana, serif; font-size=10px; Color:#000000 ">
<Input Type="button" name="BtRefresch" id="BtRefresch" Value="Recharger la liste"
style="position:absolute; left:152px; top:0px; height:22px; width:114px;
font-family:MS Sans Serif, Arial, Verdana, serif; font-size=10px; Color:#000000 ">
<SELECT name="LstPseudo" Id="LstPseudo" size="5"
style="position:absolute; left:18px; top:23px; width:248px"> </SELECT>
<TEXTAREA name="TextPseudo" id="TextPseudo"
style="background-color:white; position:absolute; left:2px; top:109px; height:28px; width:264px;
font-family:Courier New; Arial, MS Sans Serif, Verdana, serif; font-size=18px; font-weight:bold; Color:#007E3F " ></TEXTAREA>
<Input Type="button" name="BtSupList" id="BtSupList" Value="<" Title="Supprimer de la liste des pseudos"
style="position:absolute; left:241px; top:110px; height:28px; width:24px;
font-family:MS Sans Serif, Arial, Verdana, serif; font-size=10px; Color:#000000 ">
<!-- Partie prés formatage pour boite text de DVP --------------------------------------------------------------------- -->
<SELECT name="LstPhrases" Id="LstPhrases"
Style="position:absolute; left:2px; top:148px; height:22px; width:265px;
font-family:Arial, MS Sans Serif, Verdana, serif; font-size=10px; Color:#000000 "> </SELECT>
<Input Type="radio" name="XOption" id="XOption1" CHECKED
style="position:absolute; left:0px; top:165px; height:22px" >
<label for="XOption1" style="position:absolute; left:23px; top:170px;">Ajouter </label>
<Input Type="radio" name="XOption" id="XOption2"
style="position:absolute; left:59px; top:165px; height:22px" >
<label for="XOption2" style="position:absolute; left:79px; top:170px;" >Remplacer </label>
<Input Type="radio" name="XOption" id="XOption3"
style="position:absolute; left:134px; top:165px; height:22px" >
<label for="XOption3" style="position:absolute; left:155px; top:170px;" >Inserer </label>
<div style="position:absolute; left:196px; top:168px; height:18px; Color:DarkGreen;
font-family:MS Sans Serif, Arial, Verdana, serif;" ><h5>Smiley></h5></div>
<div id="divicons" style="position:absolute; left:247px; top:168px; height:17px; width:19px; text-align: center;
background-color:#C2E1FF; border:1px solid black; overflow:auto; z-index:1; cursor:default" >
</div>
<TEXTAREA name="TextMemo" draggable="true" id="TextMemo" OnMouseup="DetecteSelStart()" onkeyup="DetecteSelStart()"
style="background-color:white; position:absolute; left:2px; top:185; height:127px; width:264px;
font-family:Courier New; Arial, MS Sans Serif, Verdana, serif; font-size=10px; Color:#000000 " ></TEXTAREA>
</Body>
</HTML> |
