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 |
Partager