Multipage et Module de classe

**patricktoulon** · 03/07/2016, 17h51

re
Bonjour
et ben dis donc déjà que mon module overinout était une usine a gaz la t'a carrément construit une Zone industrielle

alors si tu avais chercher avec mon pseudo tu aurais trouver des versions plus récentes que celle que tu a pris dans les contributions

alors fait moi plaisir
1° sauve ton classeur sous un nom différent
2° vire tout code VBA ( je dis bien tout code)
3°ensuite met un moduleclasse que tu nommera "Over_switch_control" et met lui ceci

Code :

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
 
'                  *****************************************************************
'                  *        auteur:patricktoulon:alias chamalin1@msn.com           *
'                  *              date de creation: 14/06/2010                     *
'                  * sujet: Module classe pour donner l'effet mouseover et mouseout*
'                  *****************************************************************
'                               mise ajour  du 20/07/2016
'                                  NOUVELLE VERSION
'                            tout ce passe dans la classe!!!!!!!!!!!!!!!
'                               changement de strategie
'plus de redim preserve (moins de memoire utilisée
'plus de module standard pour memoriser encore plus de variables (memoire libérée)
'plus de boucle pour retrouver le control précédemment survolé
' Nouveau ajout de la manipulation des touches (TAB,Fleche haut,Fleche bas)
' remise en place de l'effet WOAOUH!!!!!( le bouton grossi legerement l'ors du survol)
'code simplifié
Public WithEvents bouton As MSForms.CommandButton
Public WithEvents optbouton As MSForms.OptionButton
Public WithEvents framm As MSForms.Frame
Public WithEvents formm As UserForm
Public WithEvents Multi As MSForms.MultiPage
Public WithEvents TexTo As MSForms.TextBox
Public WithEvents mem As MSForms.TextBox
Public WithEvents liste As MSForms.ListBox
Dim control(300) As New Over_switch_control
Dim uf As Object
Public wwoah As Boolean
Function initcontrol(usf, Optional woah As Boolean)
    wwoah = woah
    Set memo = usf.Controls.Add("Forms.TextBox.1", "memo")
    memo.Width = 0
    'Set control(1).formm = usf
    'Set control(1).mem = memo
    'i = 1
    For Each ctrl In usf.Controls
        i = i + 1
        'Debug.Print TypeName(ctrl)
        '*****************************on inclu dans la classe les listbox********************************
        If TypeName(ctrl) = "ListBox" Then
            ctrl.Tag = ctrl.BackColor & ":"
            i = i + 1: Set control(i).liste = ctrl
            Set control(i).mem = usf.Controls("memo"): Set control(i).formm = usf
        End If
        '***************************on inclu dans la classe les multipage pour remettre les controls d'origine  dans le move************
        If TypeName(ctrl) = "MultiPage" Then
            i = i + 1: Set control(i).Multi = ctrl
            Set control(i).mem = usf.Controls("memo"): Set control(i).formm = usf
        End If
        '*****************on inclu dans la classe les frames pour remettre les controls d'origine  dans le move*********************
        If TypeName(ctrl) = "Frame" Then
            ctrl.Tag = ctrl.BackColor & "::"
            i = i + 1: Set control(i).framm = ctrl
            Set control(i).mem = usf.Controls("memo"): Set control(i).formm = usf
        End If
        '************************************on inclu dans la classe les  textboxs****************************************
        If TypeName(ctrl) = "TextBox" Then
            ctrl.Tag = ctrl.BackColor & ":"
            i = i + 1: Set control(i).TexTo = ctrl
            Set control(i).mem = usf.Controls("memo"): Set control(i).formm = usf
        End If
        '**********************************on inclu dans la classe les commandbutton*****************************************
        If TypeName(ctrl) = "CommandButton" Then
            With ctrl
                .Tag = .BackColor & ":" & .ForeColor & ":" & .Caption & ":" & IIf(.Font.Bold, 1, 0) & ":" & IIf(.Font.Italic, 1, 0) & ":" & .Left & "," & .Top & "," & .Width & "," & .Height
            End With
            i = i + 1: Set control(i).bouton = ctrl
            Set control(i).mem = usf.Controls("memo"): Set control(i).formm = usf
        End If
        '**********************************on inclu dans la classe les  optionbuttons******************************************
        If TypeName(ctrl) = "OptionButton" Then
            With ctrl
                .Tag = .BackColor & ":" & .ForeColor & ":" & IIf(.Font.Bold, 1, 0) & ":" & IIf(.Font.Italic, 1, 0) & ":"
            End With
            i = i + 1: Set control(i).optbouton = ctrl
            Set control(i).mem = usf.Controls("memo"): Set control(i).formm = usf
        End If
    Next
End Function
Sub tabcontrol(ctrl)
    With ctrl
        .BackColor = vbRed
        .ForeColor = vbBlack
        mem.Value = ctrl.Name
    End With
End Sub
 
'*****************************evenement keyUP*****************************************************
Private Sub bouton_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If "94038" Like "*" & KeyCode & "*" Then
        remet_normal
        tabcontrol bouton
    End If
End Sub
Private Sub liste_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If "94038" Like "*" & KeyCode & "*" Then
        remet_normal
        tabcontrol liste
    End If
End Sub
 
Private Sub optbouton_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If "94038" Like "*" & KeyCode & "*" Then
        remet_normal
        tabcontrol optbouton
    End If
End Sub
 
Private Sub TexTo_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Debug.Print KeyCode
    If "94038" Like "*" & KeyCode & "*" Then
        remet_normal
        tabcontrol TexTo
    End If
End Sub
'***********************evenement mousedown******************************************************
Private Sub liste_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    With liste
        .BackColor = vbRed
        .ForeColor = vbBlack
    End With
End Sub
Private Sub optbouton_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    With optbouton
        .BackColor = vbRed
        .ForeColor = vbBlack
    End With
End Sub
Private Sub bouton_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    With bouton
        .BackColor = vbRed
        .ForeColor = vbBlack
    End With
End Sub
Private Sub TexTo_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    With TexTo
        .BackColor = vbRed
        .ForeColor = vbBlack
    End With
End Sub
Private Sub bouton_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    With bouton
        If mem.Value <> bouton.Name Then
            remet_normal
            .BackColor = 16452365
            .Caption = UCase(bouton.Caption)
            .Font.Bold = True: .ForeColor = vbYellow: .Font.Italic = False
            .Move .Left - 3, .Top - 3, .Width + 6, .Height + 6    ' Effet woawh!!!!
            mem.Value = bouton.Name
        End If
    End With
End Sub
Private Sub optbouton_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    With optbouton
        If mem <> optbouton.Name Then
            remet_normal
            .BackColor = vbGreen
            .Font.Bold = True
            .ForeColor = vbYellow
            .Font.Italic = False
            mem.Value = optbouton.Name
        End If
    End With
End Sub
 
 
Private Sub TexTo_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If mem <> TexTo.Name Then
        remet_normal
        If TexTo.BackColor = Split(TexTo.Tag, ":")(0) Then
            TexTo.BackColor = 6697881
        End If
        mem.Value = TexTo.Name
    End If
End Sub
Private Sub Liste_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If mem <> liste.Name Then
        remet_normal
        liste.BackColor = vbMagenta
        mem.Value = liste.Name
    End If
End Sub
Private Sub framm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    remet_normal
End Sub
Private Sub formm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    remet_normal
End Sub
Private Sub Multi_MouseMove(ByVal Index As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    remet_normal
End Sub
Sub remet_normal()
    DoEvents
    Dim ctrl As Object
    If mem.Value <> "" Then
        Set ctrl = formm.Controls(mem.Value)
        If ctrl.Tag <> "" Then
            ctrl.BackColor = Split(ctrl.Tag, ":")(0)
            Select Case TypeName(ctrl)
            Case "CommandButton"
                dimention = Split(ctrl.Tag, ":")(5)
                dimention = Split(dimention, ",")
                With ctrl
                    .Caption = Split(ctrl.Tag, ":")(2)
                    .ForeColor = Split(ctrl.Tag, ":")(1)
                    .Font.Bold = IIf(Split(ctrl.Tag, ":")(3) = 1, True, False)
                    .Font.Italic = IIf(Split(ctrl.Tag, ":")(4) = 1, True, False)
                    .Move dimention(0), dimention(1), dimention(2), dimention(3)   ' Effet woawh exit !!!!
                End With
            Case "OptionButton"
                With ctrl
                    .ForeColor = Split(ctrl.Tag, ":")(1)
                    .Font.Bold = IIf(Split(ctrl.Tag, ":")(3) = 1, True, False)
                    .Font.Italic = IIf(Split(ctrl.Tag, ":")(4) = 1, True, False)
                End With
 
            End Select
        End If
        mem.Value = ""
    End If
End Sub

ensuite dans le module du userform met ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Dim cl As New Over_switch_control
 
Private Sub UserForm_Activate()
cl.initcontrol Me, True
End Sub

voila!!! maintenant lance ton userform

Nom : demo1.gif
Affichages : 680
Taille : 190,4 Ko

allez un exemplaire :

**DS3469** · 20/07/2016, 07h04

Bonjour,

Je me permet de ré-ouvrir la discussion.
Après de multiples essais je suis parvenu à trouver la solution grâce aux conseils de patricktoulon. Je comprend un peu le principe du "tag", mais pas tout.
J'avais vu la solution avec le tag, mais ce n'était pas facile vu mon niveau (c'est pour cela que j'en étais resté à ma "zone industrielle").

Je ne sais pas si je dois ouvrir une nouvelle discussion ou pas, car le problème que je vais énoncer vient à la suite dans mon projet.
Ci-joint un fichier exemple.

J'ai bien ce que je souhaitais. Lorsque je vais dans un control, il se met en rouge jusqu'à ce que je le quitte. Si je survole un autre control avec la souris il change de couleur et le control qui a le focus reste en rouge (à l'exclusion des combobox mais j'y reviendrai).

Mon souci est dans le nouveau code utilisé, par l'intermédiaire du "tag".
En effet, pour une question de confort, j'ai utilisé le code de patricktoulon concernant le redimensionnement et l'ajout des boutons manquant sur l'USF.

Je ne suis pas sur de moi, mais comme ce code utilise un tag pour le redimensionnement, je pense qu'il y a comme une incompatibilité entre le tag pour le redimensionnement et le tag pour le changement de couleur des control.
Dans le fichier joint, si on tente de réduire l'Usf, on a un message d'erreur.
Sauriez vous corriger cela ?
J'ai également dû modifier l'effet "waouh" des control, car avec le code sur le redimensionnement cela posait probléme (les controls ne cessaient de s'aggrandir).

Pour en revenir au combobox, j'ai inséré un code pour que au fur et à mesure de la saisie, la liste se réduise lorsque l'on saisi un nom dans le control (voir combox1 > taper d'abord A puis d'autres lettres).
Mon problème est que si je mets l'événement "mouseup" dans le module de classe:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Private Sub Cbxbox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
initial
    With Cbxbox
        .BackColor = vbRed
        .ForeColor = vbBlack
    End With
End Sub

Lorsque je clique sur un nom dans la liste, celui-ci ne remonte pas dans la combobox.
Auriez vous une explication ?

Cordialement.

**patricktoulon** · 20/07/2016, 07h27

Bonjour
ben c est simple il faut tout memoriser dans le tag
Ou alors te servir du tag de l usf pour mémoriser les dim de base. De l usf
Lors. Du redim de l usf faire le calcul et appliquer la meme regle pour les controls
Encore une fois pas tres compliqué

**DS3469** · 07/08/2016, 00h42

Bonjour,

Après un petit moment d'absence, merci à patricktoulon, pour ses conseils.
J'ai effectivement réussi à tout mémoriser dans le tag.

Cordialement.

Multipage et Module de classe [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager