Images stockée dans un fichier

marcelio

XLDnaute Occasionnel
Bonjour le Forum,
Avec des listes de validation et des formules j’insère des images qui sont stocké dans un dossier (Logos) qui est dans le même répertoire que mon fichier.
Dans mon fichier j’ai plus de 50 feuilles.

Voila mon code en VBA
Le 1er pour les formules (j’en ai 33) et le second pour les listes de validation (26).

Private Sub Worksheet_Change(ByVal target As Range)
Dim image As String
Dim sh As Shape

If [AL8] <> "" Then
image = ActiveWorkbook.Path & "\Logos\" & [AL8] & ".jpg"
Shapes("Rectangle 1").Fill.UserPicture image
Else
Shapes("Rectangle 1").Fill.Visible = msoFalse
End If


If Not Intersect(target, [H13]) Is Nothing Then
If [H13] <> "" Then
image = ActiveWorkbook.Path & "\Logos\" & target.Value & ".jpg"
Shapes("Rectangle 5").Fill.UserPicture image
Else
Shapes("Rectangle 5").Fill.Visible = msoFalse
End If
End If

Je travail sur les lignes suivantes.
Pour les listes de validation elles sont de la ligne :
H13 à H25 et de V13 à V25

Et pour les formules :
AL8 à AL40

Vu le très grand nombre d’images que j’ai,
Ce que j’aimerais avoir si cela est possible c’est de stocké toutes les images dans le fichier « Logos » sans à avoir à ouvrir le fichier à chaque fois.

Merci beaucoup de votre aide
Marcelio
 

Pièces jointes

  • Fournitures.zip
    56.1 KB · Affichages: 48
  • Fournitures.zip
    56.1 KB · Affichages: 61
  • Fournitures.zip
    56.1 KB · Affichages: 59

PMO2

XLDnaute Accro
Re : Images stockée dans un fichier

Bonjour,

Je vous conseille de laisser tous vos fichiers JPG dans votre dossier "Logos" (par conséquent, ne pas créer un classeur Excel "Logos").
J'ai fait un exemple qui va chercher les images directement dans le dossier. Il faut que le classeur soit dans le même répertoire que le dossier "Logos".

Chaque fois que vous cliquerez dans une cellule de la plage concernée (H13:H25,V13:V25) une liste de choix apparaîtra (DropDown) et créera l'image choisie.

1) copiez le code suivant dans la fenêtre de code de la feuille concernée
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call DeleteDropDown
'---
With Target
  If .Rows.Count > 1 Or .Columns.Count > 1 Then Exit Sub  'si c'est plus d'une cellule, on sort
  If Application.Intersect(Target, ActiveSheet.Range(MA_PLAGE)) Is Nothing Then Exit Sub
End With
Call AddListe(Target)
End Sub

2) copiez le code suivant dans un module Standard
Code:
'### 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

Je mets un classeur exemple en pièce jointe pour faciliter.
 

Pièces jointes

  • Fournitures_pmo.zip
    73.2 KB · Affichages: 43

marcelio

XLDnaute Occasionnel
Re : Images stockée dans un fichier

Bonsoir le Forum et PM02,

Merci pour cette solution qui me plait assez bien, et pour le fichier exemple.
Notamment j'ai 2 questions.
En ce qui concerne mes cellules en AL8 à AL40 (ce sont des formules) comment faire ?
et pour quelle raison vous me conseillé de laisser tous mes fichiers JPG dans le dossier "Logos"

Bonne soirée à vous et au Forum.
Marcelio
 

PMO2

XLDnaute Accro
Re : Images stockée dans un fichier

Vu le très grand nombre d’images que j’ai
Avez-vous essayé de toutes les mettre dans le dossier "Logos" et de lancer le programme ?

En ce qui concerne mes cellules en AL8 à AL40 (ce sont des formules) comment faire ?
Ces formules ne sont pas présentes dans votre pièce jointe initiale. Je ne peux donc pas savoir ce qu'elles faisaient ni à quoi elles servaient.
 

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Images stockée dans un fichier

Bonjour,

cf PJ

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("H13:H30,V13:V30"), Target) Is Nothing And Target.Count = 1 Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
       If s.Type = 1 Or s.Type = 9 Then
          If s.TopLeftCell.Address = Target.Offset(0, 1).Address Then s.Delete
       End If
     Next s
     '--
     If Target <> "" Then
        lig = [liste].Find(Target, LookAt:=xlWhole).Row
        col = [liste].Column + 1
        For Each s In Sheets("Images").Shapes
          If s.TopLeftCell.Address = Cells(lig, col).Address Then s.Copy
        Next s
        Target.Offset(0, 1).Select
        ActiveSheet.Paste
        Selection.ShapeRange.Left = ActiveCell.Left + 7
        Selection.ShapeRange.Top = ActiveCell.Top + 5
        Target.Select
      End If
    End If
End Sub

Les images et shapes

JB
 

Pièces jointes

  • Copie de Fournitures.xls
    66 KB · Affichages: 53
  • Copie de Fournitures.xls
    66 KB · Affichages: 56
  • Copie de Fournitures.xls
    66 KB · Affichages: 59
Dernière édition:

marcelio

XLDnaute Occasionnel
Re : Images stockée dans un fichier

Bonjour le Forum, PM02 et Boisgontier,
Désolé de vous répondre si tard.
Merci messieurs pour votre aide et vos fichier exemple.
Je vais garder le fichier de Boisgontier qui iras mieux pour mon fichier original.
Par contre Boisgontier j'ai une petite demande.
Pour les listes de validation de la colonnes H13 à H25 est t'il possible de mettre l'image à gauche,
Pour les listes de validation de la colonnes V13 à V25 est t'il possible de mettre l'image à droite (ça c'est OK),
Et pour les formules AL8 à AL40 les images à gauche.

Merci messieurs de votre aide.

Marcelio
 

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Images stockée dans un fichier

Bonsoir,

cf PJ

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("H13:H25,V13:V25"), Target) Is Nothing And Target.Count = 1 Then
    ActiveSheet.Unprotect Password:=""
    decal = -1
    If Not Intersect(Range("V13:V25"), Target) Is Nothing Then decal = 1
    '-- suppression
    For Each s In ActiveSheet.Shapes
       If s.Type = 1 Or s.Type = 9 Then
          If s.TopLeftCell.Address = Target.Offset(, decal).Address Then s.Delete
       End If
     Next s
     '--
     If Target <> "" Then
        lig = [liste].Find(Target, LookAt:=xlWhole).Row
        col = [liste].Column + 1
        For Each s In Sheets("Images").Shapes
          If s.TopLeftCell.Address = Cells(lig, col).Address Then s.Copy
        Next s
        Target.Offset(, decal).Select
        ActiveSheet.Paste
        Selection.ShapeRange.Left = ActiveCell.Left + 3
        Selection.ShapeRange.Top = ActiveCell.Top
        Target.Select
      End If
      ActiveSheet.Protect Password:=""
    End If
End Sub

>Et pour les formules AL8 à AL40 les images à gauche.

Je n'ai pas compris.

Si la liste en AL est une liste comme les 2 autres

Remplacer

Code:
If Not Intersect(Range("H13:H25,V13:V25"), Target) Is Nothing And Target.Count = 1 Then

par

Code:
 If Not Intersect(Range("H13:H25,V13:V25,AL8:AL40"), Target) Is Nothing And Target.Count = 1 Then

JB
 

Pièces jointes

  • Copie de Fournitures.xls
    72.5 KB · Affichages: 50
  • Copie de Fournitures.xls
    72.5 KB · Affichages: 43
  • Copie de Fournitures.xls
    72.5 KB · Affichages: 46
Dernière édition:

marcelio

XLDnaute Occasionnel
Re : Images stockée dans un fichier

Bonsoir le Forum,
Bonsoir Boisgontier,

J'ai un petit soucis, car j'ai adapter votre exemple à mon fichier original et les images pour les formules ne s'affichent pas.
Mes formules effectuent un tri croissant.
Merci de nouveau pour votre aide.
Bonne soirée à vous et au Forum.

Marcelio
 

Pièces jointes

  • Copie de Fournitures.xls
    72.5 KB · Affichages: 27
  • Copie de Fournitures.xls
    72.5 KB · Affichages: 40
  • Copie de Fournitures.xls
    72.5 KB · Affichages: 35

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Images stockée dans un fichier

Bonsoir,

cf PJ

Code:
Private Sub Worksheet_Calculate()
  Application.ScreenUpdating = False
  ActiveSheet.Unprotect Password:=""
  For Each cel In [am8:am22]
    '-- suppression
    For Each s In ActiveSheet.Shapes
       If s.Type = 1 Or s.Type = 9 Then
          If s.TopLeftCell.Address = cel.Offset(, -1).Address Then s.Delete
       End If
     Next s
     '--
     If cel <> "" Then
        lig = [liste].Find(cel, LookAt:=xlWhole).Row
        col = [liste].Column + 1
        For Each s In Sheets("Images").Shapes
          If s.TopLeftCell.Address = Cells(lig, col).Address Then s.Copy
        Next s
        cel.Offset(, -1).Select
        ActiveSheet.Paste
        Selection.ShapeRange.Left = ActiveCell.Left + 3
        Selection.ShapeRange.Top = ActiveCell.Top
      End If
   Next cel
   ActiveSheet.Protect Password:=""
End Sub

JB
 

Pièces jointes

  • Copie de Fournitures2.xls
    78 KB · Affichages: 50
  • ClassementImages.xls
    70 KB · Affichages: 48
Dernière édition:

marcelio

XLDnaute Occasionnel
Re : Images stockée dans un fichier

Bonsoir,

Désolé de vous déranger de nouveau mais j'ai une erreur d'exécution sur mon fichier original.
erreur d'exécution '91':
Variable objet ou variable de bloc With non définie.
et cela me met en jaune la ligne de code suivante
lig = [liste].Find(Cel, LookAt:=xlWhole).Row

Merci de votre aide

Marcelio
 

Discussions similaires

Réponses
1
Affichages
269
Compte Supprimé 979
C

Statistiques des forums

Discussions
311 725
Messages
2 081 948
Membres
101 849
dernier inscrit
florentMIG