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
| Option Explicit
'Généralisation des dimensions et nombre de labels
Const Nc As Integer = 10 'nombre de labels en colonnes
Const Nl As Integer = 10 'nombre de labels en lignes
Const L As Integer = 25 'largeur des labels
Const H As Integer = 15 'hauteur des labels
Const Ec As Integer = 6 'Ecart horizontal entre labels
Const El As Integer = 5 'Ecart vertical entre labels
Dim Labels() As String
Dim Couleur() As Long
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
'Ajout des labels dans l'userform et dans le tableau TB
ReDim Couleur(1 To Nc * Nl)
ReDim Labels(Nl, Nc)
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
.BackColor = 225
Couleur(k) = .BackColor
End With
Labels(i, j) = lbl.Name
Next j
Next i
End Sub
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Static Old As Control
Dim Tmp As Control
Set Tmp = FindLabelIndex(X, Y)
If Not Old Is Nothing Then Old.BackColor = Couleur(Replace(Old.Name, "LB", ""))
If Not Tmp Is Nothing Then
Me.Caption = "Label survolé: " & Tmp.Name
Set Old = Tmp
Tmp.BackColor = vbWhite
End If
End Sub
Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim Tmp As Control
Set Tmp = FindLabelIndex(X, Y)
If Not Tmp Is Nothing Then
Me.Caption = "Clic sur: " & Tmp.Name
MsgBox Tmp.Name
End If
End Sub
Private Function FindLabelIndex(ByVal xX As Single, ByVal yY As Single) As Control
Dim lbl As Control
Dim col As Integer
col = Round((xX / (L + Ec)) + 0.5, 0)
Dim lig As Integer
lig = Round((yY / (H + El)) + 0.5, 0)
If col * lig > 0 And lig <= Nl And col <= Nc Then
Set lbl = Me(Labels(lig, col))
If xX >= lbl.Left And xX <= (lbl.Left + lbl.Width) And yY >= lbl.Top And yY <= (lbl.Top + lbl.Height) Then
Set FindLabelIndex = lbl
Else
Set FindLabelIndex = Nothing
End If
Else
Set FindLabelIndex = Nothing
End If
End Function |
