Insérer photo dans une plage de cellule via chemin

Bonjour à tous,

Je vous joins le fichier en lien avec mon problème :

2 feuilles :

- Observations : formulaire où je souhaite insérer les photos via leur chemin réseau.

Les chemins se trouvent enregistrés dans la base de donnée, dans la feuille "Data_Photos". Dans le tableau de cette feuille, 8 chemins peuvent être enregistrés. Ces chemin sont associés à une référence que l'on retrouve en première colonne du tableau mais également dans la feuille "Observations" en cellule E2.

La finalité étant d'insérer les données du tableau, dans le formulaire de la feuille "Observations" et d'insérer les photos dans leur plage de cellules respectives en utilisant leur chemin.

J'ai réussi à créer une macro "Recherche_Photo", qui via la référence en cellule E2-feuille "Observations" ; cette macro va rechercher les chemins associés à celle-ci dans la feuille "Data_Photos" et va écrire leur chemin dans leur cellule respective.

A présent, je souhaite insérer, pour chaque plage de cellules prévue, la photo au chemin correspondant et la redimensionner à la taille de la plage de cellules. Pour se faire, j'ai tenté de réutiliser une macro qui lorsqu'on double clique dans une plage de cellule définie, cela insère et redimensionne la photo dans celle-ci.

Malheureusement, je n'y suis pas parvenu, quelqu'un aurait une idée ?

Merci beaucoup !

Bonjour,

Je viens d'essayer la macro "InsertPictureInRange". Elle fonctionne et redimensionne la photo à la taille de la cellule D4. Quel est ton problème ? Y a-t-il une erreur ?

Daniel

Bonjour Daniel,

Cette macro fonctionne effectivement, mais seulement au double clique.

Ce que j'essaye de faire :

Rechercher le chemin de la photo dans la base de données à partir de la référence (macro Recherche_Photo ; fonctionne)

Insérer le chemin dans la cellule D4:H4 par exemple ( Macro Recherche_Photo ; fonctionne)

Insérer l'image dans la plage D4:H4 et la redimensionner la taille de cette plage comme le fait la macro ''InsertPicture InRange'' (ne fonctionne pas).

Merci

Bonjour

Si j'ai bien compris. La finalité serait de mettre des images dans les cellules de la plage.

Voici donc une proposition qui fait tout.
Tout se passe à partir de la liste déroulante en cellule "E2".
Quand on la selectionne elle est mise à jour avec les valeurs de la colonne 1 du tableau data_photos
Quand sa valeur change ça met à jour la plage d'images avec les chemin de la ligne correspondante dans le tableau

PS. Il y a un bug si le tableau des photos ne compte qu'une seule ligne. J'y travaille

Oui, car les cellules D4:H4 sont fusionnées. Essaie :

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
Dim p As Object
Dim t!, l!, w!, h!
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
With TargetCells
t = .Top
l = .Left
w = .Resize(, 5).Width
h = .Height
End With
With p
.Width = w
If .Height > h Then
.Height = h
.Left = l + (w - .Width) / 2
.Top = t
Else
.Left = l
.Top = t + (h - .Height) / 2
End If
End With
End Sub

Daniel

La version réparée.

Ca fonctionne, donc ?

Daniel

@DanielC
A qui s'adresse la question? Si c'est à moi oui ça fonctionne mais je ne sais pas si c'est ce qu'attendait JonVa
La même débarrassée des macros inutiles

Désolé, oui la question était pour JonVa.

Daniel

Bonjour à vous,

@Daniel, Effectivement cela fonctionnait pas si la plage était fusionnée, j'ai apporté ta modification avec Rezise, et cela fonctionne très bien !

@Yal, C'est un équivalent de ce que j'attendais, de plus le redimensionnement est mieux avec ta proposition ! Dans mon fichier source, je dois cependant garder le déclenchement de la macro via un bouton ; je vais m'inspirer de ta solution pour un autre fonctionnement :) !

Merci beaucoup à vous deux, sujet résolu ! :)

Yal,

Si d'autres personnes sont intéressés par ta solution, j'ai corrigé un "bug" :

Si on ne trouve pas le chemin d'accès spécifié dans la colonne, alors on passe à la colonne suivante.

Mais si ma colonne est vide, image prend la valeur : "" et dans ce cas une erreur "Fichier introuvable" apparaît et la macro s'arrête.

Pour corriger, j'ai simplement ajouté "On Erreur Resume Next" dans cette macro :

Sub InserePhotos(destination, image, num)
  Dim L As Single, T As Single, W As Single, H As Single
  Dim objShp As Shape

On Error Resume Next

  L = destination.Left
  T = destination.Top
  W = destination.Width
  H = destination.Height

  Set objShp = Sheets("Observations").Shapes.AddPicture(image, True, True, L, T, W, H)
  objShp.Name = "img" & num

End Sub

Voila voila, ma très légère et modeste contribution ^-^ !

Une ou plutôt deux petites remarque à propos du On Error Resume Next
Il manque On Error GoTo 0 Pour réactiver le gestionnaire d'erreur
Je n'utilise jamais cette astuce, je préfère gérer les erreurs avant qu'elles ne se produisent. C'est beaucoup plus sûr.
Et pour finir je ne vois pas à quoi il peut bien servir ici.

Ta modification ne corrige absolument pas le bug, elle le contourne c'est tout.

Pardon Yal, j'ai l'impression de t'avoir offensé, si c'est le cas, je m'en excuse, ce n'était pas mon intention, je suis qu'un débutant en VBA qui était content d'avoir obtenu le résultat souhaité, malgré que j'ai juste contourné le bug.

A savoir, si ma colonne est vide mais que la suivante ne l'est pas ; je ne souhaitais pas que la macro s'arrête à la colonne vide, mais qu'elle poursuit tout de même sur les autres colonnes.

Dans ce cas, pour corriger le problème, il y aurait fallut que j'intègre un code qui veut dire "Si ma variable est vide (If image Is Nothing then ?) alors fait la suivante jusqu'à finir tout le tableau" au lieu de "Si tu rencontre une erreur, tu poursuis jusqu'à arriver à la dernière colonne de mon tableau" ?

Et pour finir voilà la macro qui le gère effectivement

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.ScreenUpdating = False
  If Not Intersect(Target, Range("c_ref")) Is Nothing And Target.Count = 1 Then
    Dim i%, j%
    Dim tb()
    Dim image$
    Dim num%
    tb = Sheets("Data_Photos").Range("tb_RefPhotos").Value2
    Call SupprimePhotos
    For i = 1 To UBound(tb)
      If tb(i, 1) = Target.Value Then
        For j = 2 To UBound(tb, 2)
          If Not IsEmpty(tb(i, j)) = True And tb(i, j) <> "" Then
            image = tb(i, j)
            If ExistenceFichier(image) = True Then
              num = j - 1
              Call InserePhotos(Range("c_img" & j - 1), image, num)
            Else
              MsgBox "Le fichier " & tb(i, j) & " n'existe pas"
            End If
          End If
        Next j
        Exit For
      End If
    Next i
  End If
  Application.ScreenUpdating = True
End Sub