[Astuce]Affichage d'un texte sur une image au passage de la souris

[fring]

Une image insérée sur une feuille ne possède pas d'événement permettant de détecter le passage de la souris sur celle-ci.

L'astuce consiste à insérer en même temps que l'image, deux Labels transparents. Ces Labels détectent le passage de la souris via l'événement MouseMove.

Le Label1, de même dimensions que l'image, sera positionné sur celle-ci.
Au passage de la souris, le texte s'affichera via la propriété Caption de ce Label.

Le Label2, légèrement plus grand que l'image, sera positionné sous celle-ci afin de créer une zone périphérique. Lors du passage de la souris sur cette zone périphérique, le texte du Label1 sera supprimé.

Le code ci-dessous insère l'image, les deux Labels et le code permettant d'afficher le texte.

Code à insérer dans un module standard :

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
Sub insertion_image()
Application.ScreenUpdating = False
'******************************************************************
'déclaration des variables
Dim NomImg As String, NomLab As String, NomInfo As String
Dim Col As New Collection, i As Byte
Dim L As Single, T As Single, W As Single, H As Single
Dim Plage As Range, Compt As Byte, TxtInfo As String
'******************************************************************
'comptage des objets déjà insérés
Compt = Sheets("Feuil1").Shapes.Count + 1
'******************************************************************
'définition des noms des objets
NomImg = "Img" & Compt '<-- nom image
NomLab = "Lab" & Compt '<-- nom label périphérique
NomInfo = "Info" & Compt '<-- nom label info
'******************************************************************
'Définition du texte à afficher au passage de la souris
TxtInfo = "Texte Info Bulle"
'******************************************************************
'Définition de la taille et de la position par rapport à une plage de cellules
Set Plage = Range("B5:D18") '<-- plage de cellules B5:D18
L = Plage.Left '<-- position horizontale
T = Plage.Top '<-- position verticale
W = Plage.Width '<-- largeur
H = Plage.Height '<-- hauteur
'******************************************************************
'insertion et paramétrages de l'image
With Sheets("Feuil1").Pictures.Insert("C:\Repertoire\Image.jpg")
    .Name = NomImg '<-- nom
    .Left = L '<-- position horizontale
    .Top = T '<-- position verticale
    .Width = W '<-- largeur
    .Height = H '<-- hauteur
End With
'******************************************************************
'insertion et paramétrage du label périphérique
With Sheets("Feuil1").OLEObjects.Add(ClassType:="Forms.Label.1")
    .Name = NomLab '<-- nom
    .Left = L - 10 '<-- position horizontale
    .Top = T - 10 '<-- position verticale
    .Width = W + 20 '<-- largeur
    .Height = H + 20 '<-- hauteur
    .Object.BackStyle = 0 '<-- style de fond transparent
    .ShapeRange.Fill.Transparency = 1# '<-- degré de transparence maximum
    .Object.Caption = "" '<-- suppression du texte par défaut
    .ShapeRange.ZOrder msoSendToBack '<-- position à l'arrière plan
End With
'******************************************************************
'insertion et paramétrage du label info
With Sheets("Feuil1").OLEObjects.Add(ClassType:="Forms.Label.1")
    .Name = NomInfo '<-- nom
    .Left = L '<-- position horizontale
    .Top = T '<-- position verticale
    .Width = W '<-- largeur
    .Height = H '<-- hauteur
    .Object.BackStyle = 0 '<-- style de fond transparent
    .ShapeRange.Fill.Transparency = 1# '<-- degré de transparence maximum
    .Object.Caption = "" '<-- suppression du texte par défaut
    .Object.TextAlign = fmTextAlignCenter '<-- alignement du texte centré
    .Object.ForeColor = vbYellow '<-- couleur du texte jaune
    .Object.Font.Bold = True '<-- style de texte gras
End With
'******************************************************************
'insertion du code permettant d'afficher le texte au passage de la souris
Col.Add "Private Sub " & NomLab & "_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)"
Col.Add "Sheets(" & """Feuil1""" & ")." & NomInfo & ".Caption = " & """"""
Col.Add "End Sub"
Col.Add "Private Sub " & NomInfo & "_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)"
Col.Add "Sheets(" & """Feuil1""" & ")." & NomInfo & ".Caption = " & """" & TxtInfo & """"
Col.Add "End Sub"
 
With ActiveWorkbook.VBProject.VBComponents("Feuil1").CodeModule
    For i = 1 To Col.Count
        nextLine = .CountOfLines + 2
        .insertlines nextLine, Col.Item(i)
    Next
End With
'******************************************************************
Application.ScreenUpdating = True
End Sub

Fichier démo
.