Detecter le control d'un Userform sur clic

Version imprimable

Voir 40 message(s) de cette discussion en une page

24/03/2016, 11h39
patricktoulon

1 pièce(s) jointe(s)

re
Avoue quand même qu'il fallait aller la chercher celle la :ptdr:
je vais remanier les dimensions c'est un soucis de conversion rien de plus

voila change ca dans classing

Code:

If ctrl.Tag = "classe" Then codehtml = codehtml & "<div id=""" & ctrl.Name & """ style=""position:absolute;left:" & ctrl.Left & "px;top:" & ctrl.Top & "px;width:" & ctrl.Width - 2 & "px;height:" & ctrl.Height - 1 & "px;border:1px solid red""></div>"

Pièce jointe 204930
24/03/2016, 11h48
cerede2000

Ah ben c'est clair !
J'aurais pas penser aller intégrer un composant WebBrowser avec de l'HTML la dedans :mrgreen:

L'idée est pas mal, bien que quand même lourde en terme de charge (avec l'activeX Browser) j'imagine....

Mais super bien joué !!!

Edit : Nickel avec la dernière modif !!
Mais du coup tu aurais pu aller plus loin, pour gérer les couleur avec un peu de CSS et de la récup de propiétés...... :ptdr:
24/03/2016, 11h54
patricktoulon

re

attend c'est pas fini
je vais essayer de supprimer le web browser en me servant d'un htmldocument virtuel :ptdr: createobject("htmlfile")

il est barré ce toulonnais ;)
24/03/2016, 11h57
cerede2000

1 pièce(s) jointe(s)

Coooool !!

En tous cas, test utlime avec 100x100 labels de 5x5 avec 0 d’espacement.
On dépasse tout ce qu'on a déjà en fait en terme de rapidité de survol !!!!
Mais la fenêtre est plus longue à générer au départ c'est curieux.
Pièce jointe 204932
24/03/2016, 12h16
patricktoulon

re

et oui 1000 ca fait beaucoup quand même a la construction du userform et du html

et la rapidité est due au fait que l'on calcule rien on demande simplement la position de l'élément jumeau dans le webbrowser avec les coordonnées
juste la ligne elementfrompoint déclenche le tout

je test avec htmlfile mais c'est pas concluant pour le moment sans doute un soucis de handle context puisqu'il n'en a pas je vais potasser

pour accroitre la rapidité je vais voir si je peux créer les composant dans le html autrement

et l'avantage de faire comme ca c'est que c'est adaptable sur l'existant puisque les bouton sont reproduit a l'identiques dans le html ,on cherche pas la colonne la ligne etc......

on donne x et y et il nous donne ce qu'il y a au niveau de ce point
je voulais faire la même chose avec les apis de GDI + mais c'était plus lourd en terme de code et même en fonctionnement
et surtout que le webbrowser est sensé être caché

Citation:

Edit : Nickel avec la dernière modif !!
Mais du coup tu aurais pu aller plus loin, pour gérer les couleur avec un peu de CSS et de la récup de propiétés...... :ptdr:

oui j'aurais pu mais j'ai pas boulu alourdir le code
je peut te les reproduire a l'identique si tu veux

mais il me faut ma fonction de conversion de couleur long to html
mais si tu veux je t'en fait un pas de soucis
24/03/2016, 13h00
cerede2000

Pas 1000, mais 100x100 = 10 000 :)

Ben sinon stocké la couleur directement en long dans le div ou dans un span dans le div.... :)
Tant qu'a y aller, allons y franchement non :mrgreen:

Ce qui est pas mal avec cette technique c'est que même si tu as des contrôle non rangés tu peux tout récupérer dans t’embêter !
En gros tu gère une map de tes contrôls en // c'est vraiment top comme idée ;)
24/03/2016, 13h12
patricktoulon

re

re

Citation:

Ce qui est pas mal avec cette technique c'est que même si tu as des contrôle non rangés tu peux tout récupérer dans t’embêter !
En gros tu gère une map de tes contrôls en // c'est vraiment top comme idée :wink:

c'est bien ca l'idée c'est pour ca que je disais plus haut c'est adaptable a l'existant les controles n'ont pas besoins d'être rangés

c'est un mapping de la surface a contrôler

après 10000 non la je sais pas si un jour tu aura a faire un userform avec autant de controls moi je mange mon clavier

après si on veut faire un petit jeu
plutôt que de construire 1000 controls dans le userform et 1000 dans le map html on en construit 1 dans le userform et 1000 dans le map
et on lui donne les propriété de l'élément capter dans le map: left,top,width,etc......couleur, ce sera moins lourd

bref de cette façon on a beaucoup de possibilités
24/03/2016, 13h36
mercatog

Déjà tu peux construire ton codehtml au sein même de la boucle de création des labels. tu gagneras une boucle

En tout cas, bravo Patrick pour la créativité

@mercatog : tu lis dans mes pensées !!!

J'étais justement en train de modifier ça :)

Code:

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
Option Explicit
'Généralisation des dimensions et nombre de labels
Const Nc As Integer = 20    'nombre de labels en colonnes
Const Nl As Integer = 15     'nombre de labels en lignes
Const L As Integer = 20     'largeur des labels
Const H As Integer = 12   'hauteur des labels
Const Ec As Integer = 5    'Ecart horizontal entre labels
Const El As Integer = 2    'Ecart vertical entre labels
Dim Couleur() As Long    'On peut s'en passer si tous les labels ont la même couleur
Dim old
Dim sweb
Dim calco
Dim swebleft
 
Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim bouton
 
    bouton = calco.elementFromPoint(X, Y).ID
 
    MsgBox bouton
End Sub
 
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim bouton
    bouton = calco.elementFromPoint(X, Y).ID
    If bouton = "" And old <> 0 Then Me.Controls(old).BackColor = Couleur(Replace(old, "LB", ""))
 
    If bouton <> "" Then
        If bouton <> old And old <> 0 Then Me.Controls(old).BackColor = Couleur(Replace(old, "LB", ""))
 
        Me.Controls(bouton).BackColor = vbRed
        old = bouton
        Me.Caption = bouton
    End If
End Sub
 
Private Sub UserForm_Initialize()
    Dim i As Integer, j As Integer, k As Integer
    Dim Lbl As Control
    Dim ctrl As Object, codehtml
 
    swebleft = (Nc + Ec + 1) * L
 
    'Règlage de la taille et la position du contrôle image
    With Me.Image1
        .Left = 0
        .Top = 0
        .Width = Nc * (L + Ec) + 2 * Ec
        .Height = Nl * (H + El) + 2 * El
        .ZOrder 0
        .BackStyle = 0
        .BorderStyle = 0
    End With
 
    Set sweb = Controls.Add("Shell.Explorer.2", "web", True): sweb.Left = swebleft: sweb.Width = (Nc + Ec) * L + 30: sweb.Height = (Nl + El) * H + 30
    sweb.navigate "about:blank": Set calco = sweb.Document
    codehtml = codehtml & "<html><head><meta http-equiv=""X-UA-Compatible"" content=""IE=10""></head><body style="" font-size:10;"">"
 
    ReDim Couleur(1 To Nc * Nl)
    For i = 1 To Nl
        For j = 1 To Nc
            k = Nc * (i - 1) + j
            Set Lbl = Me.Controls.Add("Forms.Label.1", "LB" & k, True)
            With Lbl
                .Left = Ec + ((L + Ec) * (j - 1))
                .Top = El + ((H + El) * (i - 1))
                .Width = L
                .Height = H
                .Caption = "LB" & k
                .TextAlign = 2
                .BorderStyle = 1
                .ZOrder 1
                .Tag = "classe"
                .BackColor = ThisWorkbook.Colors(3 + (Rnd * 53))
                Couleur(k) = .BackColor
                codehtml = codehtml & "<div id=""" & .Name & """ style=""position:absolute;left:" & .Left & "px;top:" & .Top & "px;width:" & .Width - 2 & "px;height:" & .Height - 1 & "px;border:1px solid red""></div>"
            End With
        Next j
    Next i
    codehtml = codehtml & "</body></html>"
    calco.write Replace(codehtml, "><", ">" & vbCrLf & "<")
    old = 0
End Sub

@patricktoulon : pour le fun, est-ce possible d’exécuter du code JS avec l'objet calco ?
Genre quand tu survole un label, tu modifie le style de la div associé :mouarf:
getElementById Style.color ?

Edit : réponse à moi-même oui ça fonctionne !!!!
Excellent :)

Code:

calco.elementFromPoint(X, Y).Style.BorderColor = "blue"

Edit 2 : pour le fun...

Code:

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
Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim bouton
 
    bouton = calco.elementFromPoint(X, Y).ID
 
    calco.getElementByID(bouton).Style.backgroundColor = "blue"
    MsgBox bouton
    calco.getElementByID(bouton).Style.backgroundColor = "white"
End Sub
 
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim bouton
    bouton = calco.elementFromPoint(X, Y).ID
    If bouton = "" And old <> 0 Then Me.Controls(old).BackColor = Couleur(Replace(old, "LB", ""))
 
    If bouton <> "" Then
        If bouton <> old And old <> 0 Then
            calco.getElementByID(old).Style.BorderColor = "red"
            Me.Controls(old).BackColor = Couleur(Replace(old, "LB", ""))
        End If
 
        Me.Controls(bouton).BackColor = vbRed
        old = bouton
        Me.Caption = bouton
        calco.getElementByID(bouton).Style.BorderColor = "blue"
    End If
End Sub

Au survol le tour deviens bleu, au clic la div deviens bleu et reviens rouge après validation du msgbox :ptdr:
J'adore !!!!!!
Merci @patricktoulon je vais m'éclater avec ce truc.......

1 pièce(s) jointe(s)

et non !! pas dans la boucle de construction parce que sinon c'est vraiment trop perso a l'userform
voici une demo qui fonctionnera sur vos grille bien rangées et un userform avec controls existant a condition de taguer les controls avec "classe"
pour le test mettez des controls sans tag il seront quand même utilisable puisque ramenés par "zorder"
allez y tester

Code:

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
Option Explicit
Dim Couleur As Object    'on cre l'object dictionaire pour contenir les couleur les cle seront les noms,les valeur seront les couleurs
Dim old
Dim sweb
Dim calco
 
Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim bouton
 bouton = calco.elementFromPoint(X, Y).ID
MsgBox bouton
End Sub
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim bouton
 bouton = calco.elementFromPoint(X, Y).ID
If bouton = "" And old <> 0 Then Me.Controls(old).BackColor = Couleur(old)
If bouton <> "" Then
If bouton <> old And old <> 0 Then Me.Controls(old).BackColor = Couleur(old)
Me.Controls(bouton).BackColor = vbRed
old = bouton
Me.Caption = bouton
End If
End Sub
Private Sub UserForm_Initialize()
 
classing
End Sub
Sub classing()
Dim ctrl As Object, codehtml, swebleft
With Me.Image1: .Left = 0: .Top = 0: .Width = Me.InsideWidth: .Height = Me.InsideHeight: .ZOrder 0: .BackStyle = 0: .BorderStyle = 0: End With
swebleft = 2000
Set Couleur = CreateObject("Scripting.dictionary")
swebleft = Me.InsideWidth - 10
Set sweb = Controls.Add("Shell.Explorer.2", "web", True): sweb.Left = swebleft: sweb.Width = Me.InsideWidth: sweb.Height = Me.InsideHeight
sweb.navigate "about:blank": Set calco = sweb.Document
codehtml = codehtml & "<html><head><meta http-equiv=""X-UA-Compatible"" content=""IE=10""></head><body style="" font-size:10;"">"
For Each ctrl In Me.Controls
If ctrl.Tag = "classe" Then
codehtml = codehtml & "<div id=""" & ctrl.Name & """ style=""position:absolute;left:" & ctrl.Left & "px;top:" & ctrl.Top & "px;width:" & ctrl.Width - 2 & "px;height:" & ctrl.Height - 1 & "px;border:1px solid red""></div>"
Couleur(ctrl.Name) = ctrl.BackColor
Else
ctrl.ZOrder 0
End If
Next
codehtml = codehtml & "</body></html>"
calco.write Replace(codehtml, "><", ">" & vbCrLf & "<")
End Sub

c'est terrible??!!

demo avec control avec et sans tags ce qui ne réagissent pas ceux sont ceux qui ne sont pas intégrés dans la classe
Pièce jointe 204942

24/03/2016, 14h19
cerede2000

Tout bonnement excellent !!

Dommage tout de même qu'il ne soit pas possible de complètement cacher le control WebBrowser
Avec les futurs écran 4K voir plus il va falloir rajouter 100 000 pour être sur qu'il n'apparaisse pas :mrgreen:
24/03/2016, 14h20
patricktoulon

1 pièce(s) jointe(s)

re

tiens meme ceux qui se croisent
Pièce jointe 204943

Citation:

Dommage tout de même qu'il ne soit pas possible de complètement cacher le control WebBrowser

t'inquiet je travaille encore sur le "htmlfile" il est for possible que je soit obligé de transférer le .elementfrompoint dans du javascript interne

laisse déborder ma créativité :ptdr:

je tiens quand même a remercier Beginner membre actif du forum javascript qui m'a largement bien aider sur ce coup la!!!qui m'a orienté vers .elementfrompoint plutôt que mon idée de base la création de l'evenement virtuel mouse avec la librairie Yui
24/03/2016, 14h45
patricktoulon

re

************************************
CONCLUSION

pas si farfelu que ca quand même!!!!!

************************************
merci a cerede2000 d'avoir ouvert cette discution j'avais toujours remis a plus tard cet exercice
et tout les participants
je livrerais une ultime version avec utilisation réelle tool barre complète dans un userform

1 pièce(s) jointe(s)

oui oui!!! une queue :ptdr::ptdr::ptdr::ptdr:

Code:

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
Option Explicit
'Généralisation des dimensions et nombre de labels
Const Nc As Integer = 30    'nombre de labels en colonnes
Const Nl As Integer = 20     'nombre de labels en lignes
Const L As Integer = 15     'largeur des labels
Const H As Integer = 10   'hauteur des labels
Const Ec As Integer = 2    'Ecart horizontal entre labels
Const El As Integer = 2    'Ecart vertical entre labels
Dim couleur() As Long    'On peut s'en passer si tous les labels ont la même couleur
Dim old
Dim sweb
Dim calco
Dim swebleft
Dim queue As Object
Dim couleurqueue As Object
Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim bouton
 bouton = calco.elementFromPoint(X, Y).ID
MsgBox bouton
End Sub
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim bouton
 bouton = calco.elementFromPoint(X, Y).ID
If bouton <> "" And bouton <> old Then
 queue.Add bouton
couleurqueue.Add Me.Controls(bouton).BackColor
Me.Controls(bouton).BackColor = vbRed
old = bouton
Me.Caption = bouton
End If
If queue.Count > 15 Then
Me.Controls(queue(0)).BackColor = couleurqueue(0)
queue.RemoveAt (0)
couleurqueue.RemoveAt (0)
End If
End Sub
Private Sub UserForm_Activate()
classing
End Sub
Private Sub UserForm_Initialize()
    Dim i As Integer, j As Integer, k As Integer
    Dim Lbl As Control
    'Règlage de la taille et la position du contrôle image
    With Me.Image1
        .Left = 0
        .Top = 0
        .Width = Nc * (L + Ec) + 2 * Ec
        .Height = Nl * (H + El) + 2 * El
        .ZOrder 0
        .BackStyle = 0
        .BorderStyle = 0
    End With
    ReDim couleur(1 To Nc * Nl)
    For i = 1 To Nl
        For j = 1 To Nc
            k = Nc * (i - 1) + j
            Set Lbl = Me.Controls.Add("Forms.Label.1", "LB" & k, True)
            With Lbl
                .Left = Ec + ((L + Ec) * (j - 1))
                .Top = El + ((H + El) * (i - 1))
                .Width = L
                .Height = H
                .Caption = "LB" & k
                .TextAlign = 2
                .BorderStyle = 1
                .ZOrder 1
                .Tag = "classe"
                .BackColor = ThisWorkbook.Colors(3 + (Rnd * 53))
                couleur(k) = .BackColor
            End With
        Next j
    Next i
old = 0
End Sub
Sub classing()
Dim ctrl As Object, codehtml
swebleft = 2000
Set queue = CreateObject("System.Collections.Arraylist")
Set couleurqueue = CreateObject("System.Collections.Arraylist")
'swebleft = (Nc + Ec + 1) * L + 40
Set sweb = Controls.Add("Shell.Explorer.2", "web", True): sweb.Left = swebleft: sweb.Width = (Nc + (Ec)) * L + 30: sweb.Height = (Nl + El) * H + 30
sweb.navigate "about:blank": Set calco = sweb.Document
codehtml = codehtml & "<html><head><meta http-equiv=""X-UA-Compatible"" content=""IE=10""></head><body style="" font-size:10;"">"
For Each ctrl In Me.Controls
If ctrl.Tag = "classe" Then codehtml = codehtml & "<div id=""" & ctrl.Name & """ style=""position:absolute;left:" & ctrl.Left & "px;top:" & ctrl.Top & "px;width:" & ctrl.Width - 2 & "px;height:" & ctrl.Height - 1 & "px;border:1px solid red""></div>"
Next
codehtml = codehtml & "</body></html>"
calco.write Replace(codehtml, "><", ">" & vbCrLf & "<")
End Sub

Pièce jointe 205088

25/03/2016, 21h23
cerede2000

:ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr:

Hé Patrick !!!!! Fais nous un Snake comme sur 3310 :mouarf:
Avec les pommes et tout hein !!!

Voir 40 message(s) de cette discussion en une page