'### Constante à adapter ###
Const FEUILLE_IMAGES As String = "images"
'###########################
Public boolSelectionChange As Boolean
Sub GetImage(Cible As Range, Titre As String)
Dim S As Worksheet
Dim R As Range
Dim C As Range
Dim SH As Shape
Dim PIC As Excel.Picture
Dim nbCol&
Dim j&
Dim var
Dim bool As Boolean
'---
Application.ScreenUpdating = False
'--- Supprime l'image existante ---
On Error Resume Next
ActiveSheet.Shapes(Cible.Address).Delete
Err.Clear
'---
On Error GoTo Erreur
If Cible = "" Then Err.Raise 65000
'--- Recherche la correspondance ---
Set S = Sheets(FEUILLE_IMAGES)
S.Activate
var = S.[a1].CurrentRegion
'--- La bonne colonne ---
nbCol& = UBound(var, 2)
For j& = 1 To nbCol&
If var(1, j&) = Titre Then
Set R = S.Range(S.Cells(2, j&), S.Cells(UBound(var, 1), j&))
Exit For
End If
Next j&
'--- La bonne cellule ---
For Each C In R
If C = Cible Then
bool = True
Exit For
End If
Next C
'/////////////////////
'--- Si on a trouvé la bonne cellule ---
If bool Then
'--- La bonne image ---
For Each SH In S.Shapes
If SH.TopLeftCell.Address = C.Address Then
SH.Copy
Exit For
End If
Next SH
'--- Colle l'image dans la feuille appelante ---
Application.EnableEvents = False
Set S = Cible.Parent
S.Activate
Cible.PasteSpecial
'--- Propriétés de l'image collée ---
Set PIC = Selection '.OLEFormat.Object
PIC.Name = Cible.Address
PIC.Top = Cible.Top + 5
PIC.Left = Cible.Left + 10
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'°°° "BidonClic" est absolument nécessaire °°°
'°°° pour éviter la sélection des images °°°
PIC.OnAction = "BidonClic"
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
Application.EnableEvents = True
'---
boolSelectionChange = True
Else
Set S = Cible.Parent
S.Activate
End If
'---
Erreur:
Application.ScreenUpdating = True
End Sub
Sub BidonClic()
'Cette procédure est vide mais est absolument
'nécessaire pour éviter la sélection des images
End Sub