'### Constante à adapter ###
Private Const DOSSIER_IMAGES As String = "Logos" 'Nom du dossier contenant les images
Public Const MA_PLAGE As String = "H13:H25,V13:V25" 'Adresse de la plage affectée
'################################################################
Const ITEM_NUL As String = "*** Aucun ***"
Dim myColl As New Collection
Sub AddListe(R As Range)
Dim i&
Dim SH As Shape
Dim DD As DropDown
Dim T()
'--- Initialise la Collection ---
Call GetImagesByName
'--- Création d'une Shape ---
Set SH = ActiveSheet.Shapes.AddFormControl(xlDropDown, R.Left, R.Top, R.Width, R.Height)
SH.OnAction = "DropDownSurClic"
SH.Name = "___pmo"
'--- Récupération de l'objet DropDown ---
Set DD = SH.OLEFormat.Object
DD.DropDownLines = 12
'--- Mise en tableau de la Collection ---
ReDim T(1 To myColl.Count)
For i& = 1 To myColl.Count
T(i&) = myColl.Item(i&)
Next i&
'--- Affichage des items dans le DropDown ---
If UBound(T, 1) = 1 Then
DD.AddItem T(1)
Else
DD.List = T
End If
'--- Sélection du Range appelant ---
R.Select
End Sub
Sub DropDownSurClic() '### Evènement Clic sur le DropDown ###
Dim SH As Shape
Dim DD As DropDown
Dim PIC As Excel.Picture
Dim S As Worksheet
Dim R As Range
Dim R2 As Range
Dim i&
'--- Recherche du DropDown ---
Set S = ActiveSheet
For Each SH In S.Shapes
If SH.Type = msoFormControl Then
If SH.FormControlType = xlDropDown Then
Set DD = SH.OLEFormat.Object
Exit For
End If
End If
Next SH
'--- Inscription de la sélection du DropDown ---
Set R = ActiveCell
Set R2 = R.Offset(0, -1)
If DD.List(DD) = ITEM_NUL Then
R = ""
Else
R = DD.List(DD)
End If
'--- Destruction de l'image éventuellement existante ---
On Error Resume Next
Set SH = ActiveSheet.Shapes(R2)
If Err = 0 Then SH.Delete
Err.Clear
On Error GoTo 0
R2 = ""
'--- Création de l'image ---
If DD.List(DD) <> ITEM_NUL Then
Set PIC = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & DOSSIER_IMAGES & "\" & DD.List(DD) & ".jpg")
R2 = PIC.Name
With PIC
.Top = R2.Top
.Left = R2.Left
.Height = R2.Height
.Width = R2.Width
.OnAction = "ClicImage"
End With
End If
'--- Destruction du DropDown ---
Call DeleteDropDown
R2.Select
End Sub
Sub DeleteDropDown(Optional dummy As Byte)
Dim SH As Shape
'---
For Each SH In ActiveSheet.Shapes
If SH.Type = msoFormControl Then
If SH.FormControlType = xlDropDown Then
If SH.Name = "___pmo" Then SH.Cut
End If
End If
Next SH
End Sub
Sub GetImagesByName()
Dim objShell As Object 'Shell32.Shell
Dim objFolderItem As Object 'Shell32.FolderItem
Dim objFolder As Object 'Shell32.Folder
Dim A$
'---
Set myColl = Nothing
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(ThisWorkbook.Path & "\" & DOSSIER_IMAGES)
myColl.Add ITEM_NUL, ITEM_NUL
For Each objFolderItem In objFolder.Items
A$ = objFolder.getDetailsOf(objFolderItem, 0)
A$ = Mid(A$, 1, Len(A$) - 4)
myColl.Add A$, A$
Next objFolderItem
End Sub
Sub ClicImage()
'Ne pas détruire cette Sub bien qu'elle soit vide.
'Elle est nécessaire pour empêcher le déplacement des images.
End Sub