Salut

Voici un programme HTA VBScript pour compléter l'outil de rédaction de postage de DVP.

Testé avec les navigateurs:
FireFox
Intetrnet Explorer
Chrome
Edge

Sous OS:
Windows 7
Windows 10

Un ficher paramètres(.txt) personnalisable vous permet de créer des raccourcis: liens, phrases, Tags et Smileys, vous pouvez séparer chacun par un titre de rubrique.
Durant la session, vous pouvez mémoriser des pseudos colorisés suivant le statut du forumeur.

Nom : OutilsDVP7.gif
Affichages : 30
Taille : 101,0 Ko

Pour la mise au premier plan, EXCEL doit être présent sur votre système, s'il ne l'est pas, la case à cocher ne sera pas visible, vous devrez mettre votre navigateur et ce programme l'un à coté de l'autre pour pouvoir faire du drag and drop entre les deux.
Pour un fonctionnement complet, le navigateur et ce programme doivent être lancer en tant qu'administrateur, en mode normal , les échanges entre un navigateur et un programme tiers sont forcément limités (question de sécurité).

Nom : OutilsDVP8.gif
Affichages : 31
Taille : 157,9 Ko


Fichier paramètre à mettre dans le dossier du programme (entre balises [CODE][/CODE] pour pouvoir utiliser la ligne Sélectionner tout et Visualiser dans une fenêtre à part,
mais aussi pour réduire la hauteur du texte dans cette page.
Code txt : Sélectionner tout - Visualiser dans une fenêtre à part
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
Statut du forumeur(12) ou partie littérale apparaissant dans le combobox    |   couleur, rédaction de la fonction pour la boite post de DVP   |    Drapeau
Lambda|#22229C|***
Rédacteur|#22229C|***
Directeur|#FE010D|***
Rédacteur en Chef|#FE010D|***
Responsable technique|#FE010D|***
Rédacteur/Modérateur|#008D00|***
Modérateur|#008D00|***
Modératrice|#008D00|***
Chroniqueur|#008D00|***
Responsable|#DF7000|***
Responsable Modération|#DF7000|***
Community|#DF7000|***
--------------------------- URLs Forums ---------------------------|Titre|TITRE
Général Visual Basic 6 et VBScrip|http://www.developpez.net/forums/f28/autres-langages/general-visual-basic-6-vbscript/|LIEN
VB 6 et antérieur|http://www.developpez.net/forums/f285/autres-langages/general-visual-basic-6-vbscript/vb-6-anterieur/|LIEN
Vos contributions VB6|http://www.developpez.net/forums/f286/autres-langages/general-visual-basic-6-vbscript/vb-6-anterieur/vos-contributions-vb6/|LIEN
VBScript|http://www.developpez.net/forums/f292/autres-langages/general-visual-basic-6-vbscript/vbscript/|LIEN
Vos Contributions VBScript|http://www.developpez.net/forums/f515/autres-langages/general-visual-basic-6-vbscript/vbscript/vos-contributions-vbscript/|LIEN
VBA Office (Access, Excel, PowerPoint, Word....)|http://www.developpez.net/forums/f289/hardware-systemes-logiciels/microsoft-office/general-vba/|LIEN
VBA Access|http://www.developpez.net/forums/f656/hardware-systemes-logiciels/microsoft-office/access/vba-access/|LIEN
VBA Excel|http://www.developpez.net/forums/f664/hardware-systemes-logiciels/microsoft-office/excel/vba-excel/|LIEN
VBA Word|http://www.developpez.net/forums/f669/hardware-systemes-logiciels/microsoft-office/word/vba-word/|LIEN
VBA Outlook|http://www.developpez.net/forums/f681/hardware-systemes-logiciels/microsoft-office/outlook/vba-outlook/|LIEN
VBA PowerPoint|http://www.developpez.net/forums/f682/hardware-systemes-logiciels/microsoft-office/powerpoint/vba-powerpoint/|LIEN
VB.Net (VB Express, VB 2003 et supérieur)|http://www.developpez.net/forums/f486/dotnet/visual-basic-net/|LIEN
--------------------------- URLs FAQs ---------------------------|Titre|TITRE
FAQ Visual Basic|http://vb.developpez.com/faq/|LIEN
FAQ VBScript|http://vb.developpez.com/faqvbs/|LIEN
--------------------------- Outils ---------------------------|Titre|TITRE
Visual Basic 6 et VBScript - MSDN|http://vb.developpez.com/outils/?page=outils#SP6|LIEN
Visual Basic 6 et VBScript Service Pack 6|http://vb.developpez.com/outils/?page=outils#SP6|LIEN
Le débogage sous Visual Basic 6|http://darkvader.developpez.com/tutoriels/vb/debogage-visual-basic-6/|LIEN
Comment savoir si l'on utilise VBA  ou VB6 ?|http://vb.developpez.com/faq/?page=IDE#VBAouVB6|LIEN
Où trouver l'aide en ligne pour VBScript ?|http://jc.bellamy.free.fr/fr/vbsgeneralites.html|LIEN
Tous les téléchargements de ProgElecT|http://vb.developpez.com/telecharger/auteur/id/51625|LIEN
Une série de tutoriel sur la Programmation en VB6|http://gilmir.developpez.com/|LIEN
AllAPI.net - aide sur les APIs|http://allapi.mentalis.org/apilist/apilist.php|LIEN
Mes contributions VB6-VBScript|http://contrib-vb.developpez.com/ProgElecT/|LIEN
Les règles du club|http://club.developpez.com/regles/|LIEN
Aide sur l'utilisation des boutons|http://www.developpez.net/forums/d571866/club-professionnels-informatique/mode-demploi-aide-aux-nouveaux/aide-lutilisation-boutons/|LIEN
Image exemple bouton CODE|[IMG]http://club.developpez.com/aidenouveauxv2/images/819346balisescode.gif[/IMG]|PHRASE
Possibilité de voter pour ou contre un message|http://www.developpez.net/forums/d922750/club-professionnels-informatique/evolutions-club/nouveaute-possibilite-voter-contre-message/|LIEN
--------------------------- Phrases ---------------------------|Titre|TITRE
Salut, bienvenue sur DVP|Salut, bienvenue sur [B][COLOR="11705985"]DVP[/COLOR][/B]|PHRASE
Salut, bienvenue sur DVP|Salut, bienvenue sur [IMG]http://cyberzoide.developpez.com/misc/clubDeveloppeurs_original.jpg[/IMG]|PHRASE
Es tu sûr de programmer en VB6 et non .......|Es tu sûr de programmer en [B]VB6[/B] et non en [B]VBA[/B], sinon vois ce lien, |PHRASE
--------------------------- Balises CODE ---------------------------|Titre|TITRE
CODE du forum|[CODE][/CODE]|BALISES
Codeinline du forum|[Codeinline][/Codeinline]|BALISES
CODE JavaScript|[CODE=Javascript][/CODE]|BALISES
Codeinline Javascript|[Codeinline=Javascript][/Codeinline]|BALISES
CODE CSS|[CODE=CSS][/CODE]|BALISES
Codeinline CSS|[Codeinline=CSS][/Codeinline]|BALISES
CODE HTML|[CODE=HTML][/CODE]|BALISES
Codeinline HTML|[Codeinline=HTML][/Codeinline]|BALISES
CODE PHP|[CODE=PHP][/CODE]|BALISES
Codeinline PHP|[Codeinline=PHP][/Codeinline]|BALISES
--------------------------- Balises autres ---------------------------|Titre|TITRE
QUOTE|[QUOTE][/QUOTE]|BALISES
Gras|[B][/B]|BALISES
Italique|[I][/I]|BALISES
Souligné|[U][/U]|BALISES
Barré|[S][/S]|BALISES
Gras et Italique|[B][I][/I][/B]|BALISES
Surligner|[highlight][/highlight]|BALISES
Suspend l'interprétation des balises|[noparse] |BALISES
Espace insécable| |BALISES
Tab||BALISES
2 Tab|[indent=2]|BALISES
3 Tab||BALISES
--------------------------- EmoIcons ---------------------------|Titre|TITREicons
:coucou:|wavey.gif|ICONS
:salut:|salut.gif|ICONS
:nono:|nono.gif|ICONS
:cfou:|sontfous.gif|ICONS
:applo:|applo.gif|ICONS
:Zen:|zen.gif|ICONS
:pastaper:|pastaper.gif|ICONS
:resolu:|resolu.gif|ICONS
:marteau:|marteau.gif|ICONS
:scarymov:|scarymovie.gif|ICONS
:ccool:|ccool.gif|ICONS
:pleure:|pleure.gif|ICONS
:whistle:|whistle.gif|ICONS
:alerte:|alerte2.gif|ICONS
:tagcode:|code.png|ICONS
:lahola:|hola.gif|ICONS
:pc:|pc.gif|ICONS
:arf:|sacrain.gif|ICONS
:moinsser:|poucerouge.gif|ICONS
:plusser:|poucevert.gif|ICONS
:arrow:|icon_arrow.gif|ICONS
:fleche:|fleche.gif|ICONS
------ STOP ------|STOP|STOP
:dehors:|dehors.gif|ICONS
:yaisse2:|yaisse2.gif|ICONS
:mouarf1:|mouarf1.gif|ICONS
:google:|google.gif|ICONS
:google2:|google2.gif|ICONS
:!:|icon_exclaim.gif|ICONS
:mouarf2:|mouarf2.gif|ICONS
:mouarf3:|mouarf3.png|ICONS
:yaisse1:|yaisse1.gif|ICONS
:yaisse3:|yaisse3.gif|ICONS
:massacre:|massacre.gif|ICONS
:chin:|chin.gif|ICONS
:kiss:|kiss.gif|ICONS
:help:|help.gif|ICONS
:tutoriel:|tutoriel.png|ICONS
:bebe:|minibebe.gif|ICONS
:question:|icon_question.gif|ICONS
:rouleau:|rouleau.gif|ICONS
:fessee:|fessee.gif|ICONS
:salo:|salo.gif|ICONS
:hola:|desesp.gif|ICONS
:kill:|kill3.gif|ICONS
:kiss2:|kiss2.gif|ICONS
:recherch:|rechercher.png|ICONS
:idea:|icon_idea.gif|ICONS
:mur:|headbang.gif|ICONS
:evilred:|evilred.gif|ICONS
:zekill:|zekill.gif|ICONS
:king:|king.gif|ICONS
:rose:|rose.gif|ICONS
:boulet:|boulet.gif|ICONS
:rire:|rire.gif|ICONS
:wink:|icon_wink.gif|ICONS
:fem:|fem.gif|ICONS
:zzz:|zzz.gif|ICONS
:koi:|koi.gif|ICONS
:faq:|faq.gif|ICONS
:ouin:|ouin2.gif|ICONS
:sleep:|sleep.gif|ICONS
:fleur:|fleur.gif|ICONS
:langue:|langue.gif|ICONS
:langue:|langue.gif|ICONS
:cristal:|boulecristal.gif|ICONS
:pan:|pan.gif|ICONS
:nosms:|nosms.gif|ICONS
:triste:|triste.gif|ICONS
:fou:|fou.gif|ICONS
:fleur2:|fleur2.gif|ICONS
:lefou:|lefou.gif|ICONS
:-o|icon_surprised.gif|ICONS
:ange:|ange.gif|ICONS
:no:|no.gif|ICONS
:vomi:|vomi.gif|ICONS
:france:|france.gif|ICONS
:heart:|heart.gif|ICONS
:sm:|sm.gif|ICONS
:love:|love1.gif|ICONS
:x|icon_mad.gif|ICONS
:f1:|f1.gif|ICONS
:pingoin2:|pingoin2bis.gif|ICONS
:langue2:|langue2.gif|ICONS
:frenchy:|frenchy.gif|ICONS
:java:|java.gif|ICONS
:love2:|love3.gif|ICONS
:cry:|icon_cry.gif|ICONS
:piou:|piou.gif|ICONS
:wow:|wow.gif|ICONS
:furieux:|furieux.gif|ICONS
:salive:|salive.gif|ICONS
:lun:|lun.gif|ICONS
:evil:|icon_evil.gif|ICONS
:traine:|bouletr.gif|ICONS
:calin:|calin.gif|ICONS
:furax:|furieux2.gif|ICONS
:whistle2:|whistle2.gif|ICONS
:ave:|marcelpoire.gif|ICONS
:twisted:|icon_twisted.gif|ICONS
:roi:|roi.gif|ICONS
:bug:|icon_bug.gif|ICONS
:haha:|haha.gif|ICONS

Code HTML : Sélectionner tout - Visualiser dans une fenêtre à part
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>
J'ai commenté le plus possible le code.

Certaine fonctionnalité vous sembleront plus ou moins exotique, mais je ne savais pas faire autrement pour arriver à mes fins
Je serrai heureux que l'on me propose d'autres solutions pour arriver au même résultat, donc ne vous gêné pas pour faire des commentaires