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> |
Partager