Discussion :

[counterbob]

Bonjour
j'ai un formulaire avec une trentaine de labels contenant des valeurs
est-il possible d'avoir un zoom sur les labels au survol du pointeur de souris ?

j"ai essayé

Code :

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

1
2
3
Private Sub Label25_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Zoom = 150
End Sub

mais le zoom se fait sur l'ensemble du formulaire
et ne revient pas à la taille d'origine au déplacement de la souris

merci

[boisgontierjacques]

Bonjour,

Exemple pour passer en Gras

Code :

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

1
2
3
4
5
6
7
8
9
10
11
 
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  d = 3
  If X < d Or X > Label1.Width - d Or Y < d Or Y > Label1.Height - d Then
   Label1.Font.Bold = False
   Label1.Font.Size = 12
  Else
   Label1.Font.Bold = True
   Label1.Font.Size = 20
  End If
End Sub

Boisgontier

[counterbob]

Merci

j'avais déjà vu mais pour régler une taille plus importante de Label je n'ai pas trouvé.

Cordialement

[patricktoulon]

Bonsoir
tu a 30 label et tu veux un effet woah!! (zomm) sur ces control label c'est bien ca ?
dans ce cas la il va te falloir une classe control labels
si tu avais un peu cherché tu aurais trouver dans les contribs diverses versions de mon effet mouse over in out sur les controls dont un a l'effet woahw!!!
je te donne un exemple vite fait comme ca a main levée
dans ton userform avec tes labels tu met en debut de module userform

Code :

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

1
2
3
4
5
 
Dim cl As New zomm_Label
Private Sub UserForm_Activate()
cl.initlab Me
End Sub

tu vois pas compliqué
maintenant tu ajoute une classe que tu nommera "zomm-Label"
et tu va y coller ce code tout simplement

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
 
Public WithEvents Lab As msforms.Label
Public WithEvents uf As UserForm
Dim Labelo(100) As New zomm_Label
Dim userf As New zomm_Label
Function initlab(usf)
    Set mem = usf.Controls.Add("Forms.TextBox.1", "memo" & i)
    Set userf.uf = usf
    For Each ctrl In usf.Controls
        If TypeName(ctrl) = "Label" Then
            i = i + 1
            Set Labelo(i).Lab = ctrl
            ctrl.Tag = ctrl.Left & ":" & ctrl.Top & ":" & ctrl.Width & ":" & ctrl.Height & ":" & ctrl.Font.Size
        End If
    Next
End Function
Private Sub lab_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    memoire = Lab.Parent.Controls("memo").Value
    If Lab.Name <> memoire And memoire <> "" Then
        Lab.Move Lab.Left - 5, Lab.Top - 5, Lab.Width + 10, Lab.Height + 10
        Lab.Font.Size = Lab.Font.Size + 3
        With Lab.Parent.Controls(memoire)
            .Left = Split(Lab.Parent.Controls(memoire).Tag, ":")(0)
            .Top = Split(Lab.Parent.Controls(memoire).Tag, ":")(1)
            .Width = Split(Lab.Parent.Controls(memoire).Tag, ":")(2)
            .Height = Split(Lab.Parent.Controls(memoire).Tag, ":")(3)
            .Font.Size = Split(Lab.Parent.Controls(memoire).Tag, ":")(4)
        End With
    End If
    Lab.Parent.Controls("memo").Value = Lab.Name
End Sub
Private Sub Uf_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    memoire = uf.Controls("memo").Value
    If uf.Controls("memo").Value <> "" Then
        uf.Controls(memoire).Left = Split(uf.Controls(memoire).Tag, ":")(0)
        uf.Controls(memoire).Top = Split(uf.Controls(memoire).Tag, ":")(1)
        uf.Controls(memoire).Width = Split(uf.Controls(memoire).Tag, ":")(2)
        uf.Controls(memoire).Height = Split(uf.Controls(memoire).Tag, ":")(3)
    End If
End Sub

voila encore une fois c'est pas compliqué
demo en image

voila voila

[patricktoulon]

et au propre la classe ca donne ca

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
Public WithEvents Lab As msforms.Label
Public WithEvents memo As msforms.TextBox
Public WithEvents uf As UserForm
Dim Labelo(100) As New zomm_Label
 
Function initlab(usf)
    Set mem = usf.Controls.Add("Forms.TextBox.1", "memo" & i): mem.Width = 0
    For Each ctrl In usf.Controls
        If TypeName(ctrl) = "Label" Then
            i = i + 1
            Set Labelo(i).Lab = ctrl: Set Labelo(i).memo = mem: Set Labelo(i).uf = usf:
            With ctrl: .Tag = .Left & ":" & .Top & ":" & .Width & ":" & .Height & ":" & .Font.Size: End With
        End If
    Next
End Function
 
Private Sub lab_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
       If Lab.Name <> memo.Value Then
        Lab.Move Lab.Left - 5, Lab.Top - 5, Lab.Width + 10, Lab.Height + 10
        Lab.Font.Size = Lab.Font.Size + 3
        If memo.Value <> "" Then
            t = Split(uf.Controls(memo.Value).Tag, ":")
            With uf(memo.Value): .Move t(0), t(1), t(2), t(3): .Font.Size = t(4): End With
        End If
    End If
    memo.Value = Lab.Name
End Sub
 
Private Sub Uf_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If memo.Value <> "" Then
        t = Split(uf.Controls(memo.Value).Tag, ":")
        With uf(memo.Value): .Move t(0), t(1), t(2), t(3): .Font.Size = t(4): End With
    End If
    memo.Value = ""
End Sub

[patricktoulon]

et allez!! jamais 2 sans 3
je trouve bien dommage qu'avec une classe on ne puisse pas atteindre toutes les propriété du userform
j'ai donc revu la copie afin de supprimer le besoins d'ajouter un textbox mémoire pour le dernier control survolé
en effet uf.tag génère une erreur dans la classe car cette propriété n'est pas accessible via les modules classe
par contre dans la classe j'ai les controls et si je fait uf.controls(1).parent.tag j'obtient bien le tag du userform
j'inclus donc toujours le usf dans la classe pour l'evenement move mais pour mémoriser et lire le nom du controls précèdant survolé j'utise le ".parent.tag du controls(1) de l'userform
et le tour est joué

voila

Code :

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

1
2
3
4
Dim cl As New zomm_Label
Private Sub UserForm_Activate()
cl.initlab Me
End Sub

et maintenant la classe

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
Option Explicit
Public WithEvents Lab As msforms.Label
Public WithEvents uf As UserForm
Dim Labelo(100) As New zomm_Label
Function initlab(usf)
    Dim ctrl As Object, i As Long
    For Each ctrl In usf.Controls
        If TypeName(ctrl) = "Label" Then
            i = i + 1: Set Labelo(i).Lab = ctrl: Set Labelo(i).uf = usf:
            With ctrl: .Tag = .Left & ":" & .Top & ":" & .Width & ":" & .Height & ":" & .Font.Size: End With
        End If
    Next
End Function
Private Sub lab_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
       Dim t As Variant
       If Lab.Name <> Lab.Parent.Tag Then
                Lab.Move Lab.Left - 5, Lab.Top - 5, Lab.Width + 10, Lab.Height + 10: Lab.Font.Size = Lab.Font.Size + 3
        If Lab.Parent.Tag <> "" Then
            t = Split(uf.Controls(Lab.Parent.Tag).Tag, ":")
            With uf(Lab.Parent.Tag): .Move t(0), t(1), t(2), t(3): .Font.Size = t(4): End With
        End If
    End If
    Lab.Parent.Tag = Lab.Name
  End Sub
Private Sub Uf_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim oldcontrolName As String, t As Variant
    oldcontrolName = uf.Controls(1).Parent.Tag
    If oldcontrolName <> "" Then
        t = Split(uf.Controls(oldcontrolName).Tag, ":")
        With uf(oldcontrolName): .Move t(0), t(1), t(2), t(3): .Font.Size = t(4): End With
    End If
    uf.Controls(1).Parent.Tag = ""
End Sub

voila voila