XL 2016 Cadrage et propriété d'images issues d'une macro

Anthonymctm

XLDnaute Occasionnel
Bonjour à tous,

J'ai trouvé sur le net un code assez sympa (qui date de 2010) qui me permet d'insérer une image dynamique dans une cellule qui contient une formule type =image("nomdufichier";"C:\chemindudossier")

le code :

VB:
Function Image(img_nom As Variant, Optional chemin As String = "") As String
    ' Declaration des variables
    Dim ref As Range, sh As Shape, drap As Boolean
    ' ref : la cellule qui provoque la fonction
    ' sh : les shapes
    ' Drap : drapeau definissant si la shape est trouvée
    Application.Volatile ' defini une fonction qui se recalcule automatiquement
' teste le type de variable soit une cellule soit une valeur alphanumerique
    Select Case TypeName(img_nom)
        Case "Range" ' c'est une reference cellule
            Image = img_nom.Value
        Case "String" ' c'est une valeur alphanumerique
            Image = img_nom
        Case Else ' c'est une erreur
            Image = "#ERROR"
            Exit Function
    End Select
' le chemin est un parametre optionnel, s'il est omis, la valeur est le chemin du classeur
    If chemin = "" Then chemin = ThisWorkbook.Path
' le chemin ne se termine pas forcemment par \ je le rajoute
    If Right(chemin, 1) <> "\" Then chemin = chemin & "\"
    Set ref = Application.Caller ' affectaction à ref de la cellule qui lance la fonction
   If ref.MergeCells = True Then Set ref = ref.Worksheet.Range(ref.MergeArea.Address)
    drap = False ' initialisation du drapeau
    For Each sh In ref.Worksheet.Shapes ' je passe en revue toute les shapes
' je teste son nom construite plus bas pour savoir si c'est la bonne shappe
        If "Img-" & ref.Address = Left(sh.Name, Len(ref.Address) + 4) Then drap = True: Exit For
    Next
    If drap = True Then ' c'est la bonne shape
' je teste maintenant si c'est la meme que celle de la formule pour ne pas refaire le traitement
' Le gain de temps n'est pas negligeable
       If "Img-" & ref.Address & "-" & Image = sh.Name Then GoTo fin ' egalité parfaite, je sors
    End If
    On Error Resume Next ' controle d'erreur, si la shape n'existe pas encore, l'instruction suivante provoque une erreur
    sh.Delete ' je detruits la shap
    If Image = "" Then Exit Function ' la valeur est à "" alors pas de shape à affecter
' j'inserre la shape, avec l'image en lui mettant les tailles necessaires pour la cellule
    Set sh = ref.Worksheet.Shapes.AddPicture(chemin & Image, True, True, ref.Left, ref.Top, ref.Width, ref.Height)
    sh.Name = "Img-" & ref.Address & "-" & Image ' je definis son nom pour la trouver plus tard
fin:
    Image = "Img" & ref.Address ' j'affecte un nom pour resultat
End Function

Ca fonctionne très bien, mais j'aurai juste besoin d'ajuste un peu la mise en forme des images importées. :)
Avec ce code l'image fait la taille maximale qu'elle peut prendre (avec déformation et la propriété déplacer sans dimensionner), il faudrait que :
- L'image soit centrée dans la cellule
- Qu'il y ait un peu de marge autour de l'image (de sorte à ce que ça ne dépasse pas sur les traits)
- Que les proportions initales soit respectée
- Qu'elles soient en mode déplacer et dimensionner avec les cellules (comme ça je peux les masquer)

Je vous joins l'image également pour tester, il faut juste modifier le chemin dans C6.

Evidemment, si vous avez une meilleure façon d'importer une image dans une cellule en allant la chercher dans un répertoire et qui respecte mes besoins, je suis preneur !! :)
 

Pièces jointes

  • Test import image.xlsm
    183.8 KB · Affichages: 13
  • Bande1.png
    Bande1.png
    13.5 KB · Affichages: 27
Dernière édition:

D.D.

XLDnaute Impliqué
Bonjour ;)

Pour le cadre blanc et le centrage, tu peux modifier la ligne :
sh.Name = "Img-" & ref.Address & "-" & Image ' je definis son nom pour la trouver plus tard


en
With sh
.Name = "Img-" & ref.Address & "-" & Image ' je definis son nom pour la trouver plus tard
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(255, 255, 255)
.Line.Transparency = 0
.Line.Weight = 10
.Placement = xlMoveAndSize
End With

en revanche j'ai du mal avec la partie proportion car l'image ne veut pas prendre les instructions avant son affichage on dirait.
 

D.D.

XLDnaute Impliqué
Oups... Trop vite....
et modifie la ligne
Set sh = ref.Worksheet.Shapes.AddPicture(chemin & Image, True, True, ref.Left, ref.Top, ref.Width, ref.Height)
en
Set sh = ref.Worksheet.Shapes.AddPicture(chemin & Image, True, True, ref.Left + 11, ref.Top + 11, ref.Width - 21, ref.Height - 21)
 

Anthonymctm

XLDnaute Occasionnel
Le retour de mon messie :D

A première vu ça à l'aire top !

Merci :)

Pour la proportion, j'ai retrouvé un ancien fichier qui copie des images puis regarde leur dimensions et fait augmenter la largeur et la hauteur au maximum jusqu'a ce que l'une d'entre elle atteigne les limites de la cellule (en l’occurrence hauteur de la ligne 5 ou largeur de colonne de C:D.

Maintenant c'est surement pas applicable puisque nos images ne sont pas encore dans le fichier ? :confused:

Et je suppose qu'on peut pas avoir de post traitement une fois l'image arrivée ?

En parlant de post traitement, est-ce qu'on pourrait une petite macro qui actualise les images ?
Type : -Sélection de toutes les image de l'onglet
-Suppression
-Actualisation des cellules de la colonne C

Je pense que je peux réussir la suppression et l'actualisation (avec sélection C4 puis entrée, entrée, entrée, etc) par l’enregistreur de macro.
Mais la partie sélection de toutes les images, ça je sais pas :confused:
 

Pièces jointes

  • Stock test(2) (3).xlsm
    924.1 KB · Affichages: 11

D.D.

XLDnaute Impliqué
Coucou.

Bah, la sélection et l’effacement c'est simple:
ActiveSheet.Shapes.SelectAll
Selection.Delete

Par contre ton fichier ne fait pas référence à des images stockées sous fore de fichier → actualisation impossible après.
 

Anthonymctm

XLDnaute Occasionnel
Le dernier fichier que je t'ai envoyé c'était surtout pour voir si on pouvait extraire quelque chose pour le dimensionnement proportionnel des images ^^'

En tout cas merci encore pour ton aide ! :D

Même si on ne parviens pas à garder les images proportionnelles, c'est déjà très bien ! ;)
 

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

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