'### Constantes à adapter (nom des feuilles concernées) ###
Const LISTE_PIEGES As String = "Liste des pièges"
Const FEUILLE_IMAGES As String = "Imgs"
'##########################################################
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'°°° CREATION DES BOUTONS °°°
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°
Sub CreeBoutons()
Dim S As Worksheet
Dim R As Range
Dim R2 As Range
Dim REC As Excel.Rectangle
Dim var
Dim i&
'--- Supprime tous les rectangles ---
Call DeleteBoutons
'--- Région courante à partir de A1 ---
Set S = ThisWorkbook.Sheets(LISTE_PIEGES)
var = S.[a1].CurrentRegion 'monte les données dans un Variant
'---
For i& = 2 To UBound(var, 1)
Set R = S.Range("a" & i& & "")
Set R2 = R.Offset(0, 1)
'--- Crée le rectangle ---
Set REC = S.Rectangles.Add(R2.Left + 2, R2.Top + 2, R2.Width - 4, R2.Height - 4)
'--- Propiétés du rectangle ---
REC.Name = R 'Nom (correspond à valeur de la cellule à gauche)
REC.Text = Chr(78) 'Texte
REC.Interior.Color = 14281213 'Intérieur
REC.OnAction = "Bouton_Click" 'OnAction (procédure commune à tous les rectangles)
With REC.Border 'Bordures
.Color = vbBlack '14281213
.Weight = 1
End With
With REC.Font 'Police
.Name = "Webdings"
.Size = 20
.Color = 13382400
End With
Next i&
End Sub
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'°°° POUR SUPPRIMER LES BOUTONS et/ou LES IMAGES °°°
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
Sub DeleteBoutons()
Dim SH As Shape
'---
On Error Resume Next
For Each SH In ActiveSheet.Shapes
If InStr(1, SH.OnAction, "Bouton_Click") > 0 Then SH.Delete
Next SH
End Sub
Sub DeleteImages()
Dim SH As Shape
'---
On Error Resume Next
For Each SH In ActiveSheet.Shapes
If InStr(1, SH.OnAction, "Image_Click") > 0 Then SH.Delete
Next SH
End Sub
'°°°°°°°°°°°°°°°°°°°°°°°°°
'°°° PROCEDURES ACTION °°°
'°°°°°°°°°°°°°°°°°°°°°°°°°
Private Sub Bouton_Click()
Dim REC As Object 'on ne peut typer par Excel.Rectangle car l'application peut également l'interpréter comme une TextBox
Dim PIC As Excel.Picture
Dim WB As Workbook
Dim S As Worksheet
Dim OldR As Range
Dim R As Range
Dim C As Range
Dim SH As Shape
Dim bool As Boolean
'/// FEUILLE DES IMAGES (SOURCE) ///
Set WB = ThisWorkbook
Set S = WB.Sheets(FEUILLE_IMAGES)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[a1].End(xlDown).Row, 1))
'--- Recherche de correspondance - Qui a appelé VS Liste en colonne A ---
For Each C In R
If C = Application.Caller Then
bool = True
Exit For
End If
Next C
If Not bool Then Exit Sub 'on sort si aucune correspondance
'--- Copie l'image trouvée ---
For Each SH In S.Shapes
If SH.TopLeftCell.Address = C.Offset(0, 1).Address Then
SH.Copy
End If
Next SH
'/// FEUILLE DE DESTINATION (feuille active ) ///
Set S = WB.Sheets(LISTE_PIEGES)
Set OldR = ActiveCell 'La cellule active est mémorisée
'--- Récupération de l'objet Rectangle ---
Set REC = S.Shapes(Application.Caller).OLEFormat.Object
Set R = S.Range(REC.TopLeftCell.Address)
On Error Resume Next
S.Shapes(R.Address).Delete 'si l'image est déjà existante, on la supprime
On Error GoTo 0
'--- Collage de l'image dans la cellule appropriée ---
R.Offset(0, 1).PasteSpecial
'--- Récupération de l'objet Picture ---
Set PIC = Selection
PIC.Name = R.Address 'nom
PIC.OnAction = "Image_Click" 'action
'--- Sélection de la cellule mémorisée ---
OldR.Select
End Sub
Private Sub Image_Click()
Dim SH As Shape
'---
Set SH = ActiveSheet.Shapes(Application.Caller)
'--- Met l'image au premier plan ---
SH.ZOrder msoBringToFront
'--- Exemple d'action : Effet limité de zoom de l'image ---
If SH.Height < 100 Then
SH.Height = SH.Height * 1.2
SH.Width = SH.Width * 1.2
Else
MsgBox "Cliquez sur l'oeil en colonne B pour revenir à la taille initiale"
End If
End Sub
