XL 2016 Adapter une image à une cellule

[Alyogali]

[Edit complet de mon post d'origine]

Bonjour tout le monde,

Mon dernier projet en date (et donc celui qui me pose problème et qui m'a conduit jusqu'à ce forum) c'est de créer des fiches pour mes jeux de société.
J'aurais pu faire une base de données access ou un publipostage sous word mais pour de sombres et obscures raisons j'ai fait ça sous excel.

Je vais essayer d'expliquer tout ça le plus simplement et clairement possible...

J'ai deux feuilles excel :

• une première feuille qui regroupe la liste des jeux avec les informations (nombre de joueurs, durée, mécanique, blablabla)
• et une seconde feuille excel j'ai fait une mise en page pour chaque jeu.

Avec une fonction recherche j'arrive à bien importer toutes mes données : je tape le nom du jeu comme nom de feuille excel et ensuite ça rempli automatiquement toutes les informations sur la page.
Là où je sèche, c'est pour importer les images (une image de la boite et une image du matériel).

L'idée souhaitée c'est que quand je modifie le nom de l'onglet, toute la page s'actualise pour le jeu correspondant. Donc les valeurs (ça c'est bon, je sais faire) mais aussi que la photo du jeu s'affiche dans la cellule (cellules fusionnées) correspondante en s'ajustant à la cellule (centrée et ajustée à la hauteur et ou largeur de la cellule).

J'ai trouvé un code VBA qui fait bien le boulot sur un site que j'ai vu très souvent conseillé sur les forums.
http://boisgontierj.free.fr/pages_site/lesimages.htm#FonctionAffiche

Sauf que l'image rempli toute la cellule.
Je souhaiterais que l'image s'adapte à la hauteur de la cellule et se centre dans la largeur.

Sur ce même site il y a d'autres codes qui devraient pouvoir faire ça mais je n'y connais rien en VBA et aucun ne fonctionne.

Est-ce que quelqu'un pourrait m'aider à adapter le code suivant pour adapter l'image à la cellule ?
Merci d'avance.

Function AfficheImage(NomImage, Optional rep As String)
Application.Volatile
If IsMissing(rep) Then rep = ThisWorkbook.Path & "\"
Set f = Sheets(Application.Caller.Parent.Name)
Set adr = Application.Caller
Set adr2 = Range(adr.Address).MergeArea
temp = NomImage & "_" & adr.Address
Existe = False
For Each s In adr.Worksheet.Shapes
If s.Name = temp Then Existe = True
Next s
If Not Existe Then
For Each k In adr.Worksheet.Shapes
If Mid(k.Name, InStr(k.Name, "_") + 1) = adr.Address Then k.Delete
Next k
f.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, adr2.Width, adr2.Height).Name = NomImage & "_" & adr.Address
End If
End Function

 

[Eric KERGRESSE]

Bonjour,

Une autre fonction :

Function Insere_image2(ByVal NomImage As String, ByVal Repertoire As String)
 
Dim FicImg As String, Ad As String
Dim GaucheMilieuCellule As Double
 
        With Selection
             Ad = Selection.Address
             GaucheMilieuCellule = .Left + .Width / 2
        End With
        FicImg = Repertoire & "\" & NomImage
 
        ActiveSheet.Pictures.Insert(FicImg).Select
        With Selection.ShapeRange
             .LockAspectRatio = True ' proportions d'origine lorsque vous la redimensionnez
             .Top = Range(Ad).Top
             .Height = Range(Ad).Height
             .Left = GaucheMilieuCellule - .Width / 2
        End With
 
        With Selection
             .Placement = xlMoveAndSize
             .PrintObject = True
        End With
 
End Function

Ou sous forme du procédure :

Sub Insere_image()
 
Dim FicImg As Variant
Dim Ad As String
Dim GaucheMilieuCellule As Double
 
        ChDir ThisWorkbook.Path
        With Selection
             Ad = Selection.Address
             GaucheMilieuCellule = .Left + .Width / 2
        End With
        FicImg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")
        If FicImg = "Faux" Then Exit Sub
 
        ActiveSheet.Pictures.Insert(FicImg).Select
        With Selection.ShapeRange
             .LockAspectRatio = True ' proportions d'origine lorsque vous la redimensionnez
             .Top = Range(Ad).Top
             .Height = Range(Ad).Height
             .Left = GaucheMilieuCellule - .Width / 2
        End With
 
        With Selection
             .Placement = xlMoveAndSize
             .PrintObject = True
        End With
 
End Sub

 

[patricktoulon]

bonjour
XLD a un moteur de recherche

centrer une image dans un range en toute circonstances quel que soit le ratio (range/image)

bonjour a tous voici deux méthode avec exemple pour centrer une image sur un range la méthode que j'appelle directe en effet j'agit directement sur l'image en bloquant l'apect ratio...

excel-downloads.com

la méthode directe

Sub test1()
 Dim Shap as shape
set shap=activesheet.shapes("monbateau")
PlaceThePictureInCenterRange [C4].MergeArea, shap, 90    'le dernier argument c'est la marge (facultatif)
End sub

Sub PlaceThePictureInCenterRange(rng As Range, Obj As Variant, Optional PercentMarge As Long = 100)     'la marge exprime un pourcentage de 1 à x%
    Dim Ratio#, Wx#, Yx#
    Wx = rng.Cells(1).MergeArea.Width * (PercentMarge / 100)
    Yx = rng.Cells(1).MergeArea.Height * (PercentMarge / 100)
    Ratio = Application.Min(Wx / Obj.Width, Yx / Obj.Height)
    With Obj
        If TypeName(Obj) = "Shape" Then .LockAspectRatio = msoTrue Else .ShapeRange.LockAspectRatio = msoTrue
        .Width = .Width * Ratio
        .Top = rng.Top + ((rng.Cells(1).MergeArea.Height - .Height) / 2)
        .Left = rng.Left + ((rng.Cells(1).MergeArea.Width - .Width) / 2)
    End With
End Sub

la méthode indirecte

Sub test()
    Dim shap, t
    Set shap = ActiveSheet.Shapes("shapebleue")
    t = GetDimensionPictureRatio([C4].MergeArea, shap, 90)
    With shap
        .LockAspectRatio = False
        .Left = t(1)
        .Top = t(2)
        .Width = t(3)
        .Height = t(4)
    End With
End Sub

Function GetDimensionPictureRatio(rng As Range, Obj As Variant, Optional PercentMarge As Long = 100)     'la marge exprime un pourcentage de 1 à x%
    Dim Ratio#, Wx#, Yx#, t(1 To 4)
    Wx = rng.Cells(1).MergeArea.Width * (PercentMarge / 100)
    Yx = rng.Cells(1).MergeArea.Height * (PercentMarge / 100)
    Ratio = Application.Min(Wx / Obj.Width, Yx / Obj.Height)
    t(3) = (Obj.Width * Ratio)
    t(4) = (Obj.Height * Ratio)
    t(1) = rng.Left + ((rng.Width - t(3)) / 2)
    t(2) = rng.Top + ((rng.Height - t(4)) / 2)
     GetDimensionPictureRatio = t
End Function

 

[Alyogali]

Merci beaucoup pour vos réponses mais comme je disais : je n'y connais RIEN en VBA.
Donc soit j'ai besoin de quelqu'un qui adapte la formule que j'ai trouvée (qui d'ailleurs ne marche plus ce matin alors que je n'ai rien changé), soit quelqu'un qui m'explique un minimum ce que je dois faire.

Bonjour,

Une autre fonction :

Si je comprend bien ces deux fonctions (ou procédures) sont censées fonctionner en remplacement de celle que j'utilise pour l'instant.
Mais comment je dois les utiliser ?
Si je remplace uniquement le texte dans VBA cela ne fonctionne pas.
Ce qui est logique puisque pour le coup il faut aussi que je change le texte dans ma cellule excel.
Mais je dois entrer quoi comme texte ?

J'ai tenté, pour ta première proposition, avec =Insere_image2 et Insere_image2 et pour la seconde proposition avec =Insere_image(Z2) ou Insere_image(Z2) [Z2 étant la cellule avec le lien du jeu à rechercher).
Mais cela ne marche pas.

bonjour
XLD a un moteur de recherche

Merci mais j'ai cherché.
Et pas que sur ce forum d'ailleurs...
Le problème c'est que partout tu trouves tout un tas de codes qui sont censés pouvoir faire ce que je cherche.
Mais comme je n'y connais rien, je ne sais pas comment les utiliser.
Les deux codes que tu donnes ont l'air super mais je dois en faire quoi ?
Je l'ai dit : je n'y connais RIEN.
Est-ce que je dois ajouter le code à la suite du "mien" ?
L'insérer quelque part au milieu ? Mais où ?
Est-ce qu'il y a quelque chose à modifier ?

J'ai testé un peu quelques trucs mais rien n'a fonctionné.
J'ai supposé que PlaceThePictureInCenterRange [C4] indiquait peut-être l'emplacement de la photo donc j'ai remplacé C4 par A1 (la cellule avec mon image) mais sans succès.
J'ai bien envie de comprendre, mais pour l'instant tout ça c'est du chinois pour moi...



PS: mon code d'hier ne fonctionnait pas en indiquant comme source d'image Images\Boite\Karuba.png alors que ça fonctionne si j'indique le lien complet E:\Jeux de plateau\zzz - fiches jeux\Images\Boite\Karuba.png.
Vous sauriez me dire pourquoi ?

Au pire ça restera comme ça, l'important c'est que ça marche, il faudra juste que je me rappelle de ne jamais toucher à arborescence de ces dossiers.
Mais j'aurais bien aimé comprendre...

 

[patricktoulon]

Bonjour
un fichier serait le bien venu
là comme ça ce que l'on t'a donné c'est du tout mâché donc si ça ne fonctionne pas c'est qu'il y a d'autres paramètres en prendre en compte

 

[Lu76Fer]

Bonjour Alyogali,

La source que l'on vous a fourni peut être utile pour s'inspirer du code mais si vous avez des soucis pour l'utiliser c'est normal car j'ai remarqué que l'utilisation de :

Application.Volatile

est très particulière : votre fonction sera rappelé à chaque fois que vous modifié une cellule et si une erreur est présente dans le code, cela provoque une sortie sans signaler les erreurs...

Je vous conseille du coup de retirer cette ligne...

Sinon, il y a une erreur assez grossière dans ce code au début :

Function AfficheImage(NomImage, Optional rep As String)
Application.Volatile
If IsMissing(rep) Then rep = ThisWorkbook.Path & "\"

La dernière ligne de code peut aussi être supprimé car elle ne sert à rien et la condition ne peut jamais se déclencher car IsMissing ne fonctionne qu'avec une variable de type VARIANT.

 

[Alyogali]

Bonjour
un fichier serait le bien venu
là comme ça ce que l'on t'a donné c'est du tout mâché donc si ça ne fonctionne pas c'est qu'il y a d'autres paramètres en prendre en compte

Je n'ai pas joins de fichier puisqu'il s'agit de joindre un élément qui n'est pas dans le fichier mais sur mon disque dur donc ça me paraissait inutile.
Mais si cela peut vous aider à m'aider...

En gros quand je change le nom du jeu (nom de l'onglet), ça change le nom du jeu sur le haut de la fiche, ça change le lien vers le jeu sur la page de droite qui ne sera pas imprimée et surtout ça affiche la photo correspondante au jeu.
Comme toutes les boites de jeu ont des tailles différentes, mon objectif c'est que cette image du jeu (la couverture de la boite en l'occurrence, même si ça n'a aucune espèce d'importance pour excel) se centre dans la cellule en gardant la hauteur d'origine alors que là, la photo rempli toute la cellule (groupe de cellules fusionnées) et donc est déformée.

Bonjour @Alyogali,

J'ai modifié le code selon vos indications.
Merci.

 

[patricktoulon]

re
deja nommer un image insérée avec le chemin complet + topleftcell.address n'est pas une bonne idée
il y a des caractères qu'il vaut mieux éviter dans les noms d'object (quels qu'ils soient) dans une feuille

 

[Eric KERGRESSE]

A tester. Clic-droit ou changement des cellules dans la colonne A de la feuille 2.

 

[Alyogali]

A tester. Clic-droit ou changement des cellules dans la colonne A de la feuille 2.

Ça marche mais il faut sélectionner la photo dans la colonne A.
Moi je veux que ça se fasse tout seul, dès que le nom de l'onglet est modifié.
C'est ce que fait la code que j'ai utilisé, mais sans adapter la photo à la cellule...

 

[Lu76Fer]

Ça marche mais il faut sélectionner la photo dans la colonne A.
Moi je veux que ça se fasse tout seul, dès que le nom de l'onglet est modifié.
C'est ce que fait la code que j'ai utilisé, mais sans adapter la photo à la cellule...

Voici une version modifiée qui devrait répondre au cahier des charges.
J'ai ajouté un onglet ListeJeux avec un tableau dans lequel il faudra dupliquer et insérer chaque nouveau jeu en modifiant la 1ere colonne et en la faisant pointer sur le nom du nouveau jeu (dans sa feuille)
J'ai emprunter la fonction patricktoulon pour recentrer l'image.
Au moment de créer la fiche il faudra prendre un nom d'onglet générique (ex: jeu), faire le lien dans le tableau puis renommer l'onglet avec le bon nom.

 

[Lu76Fer]

Ça marche mais il faut sélectionner la photo dans la colonne A.
Moi je veux que ça se fasse tout seul, dès que le nom de l'onglet est modifié.
C'est ce que fait la code que j'ai utilisé, mais sans adapter la photo à la cellule...

Je crois que j'avais mal compris et qu'il n'y a qu'un onglet mais c'est le contenu qui change, cela simplifie du coup.
J'ai renommé l'onglet 'ListeJeux' en 'Param' et il suffit de paramétrer les chemins de fichier utilisés.

 

[Alyogali]

Voici une version modifiée qui devrait répondre au cahier des charges. J'ai ajouté un onglet ListeJeux avec un tableau Merci, ça fonctionne super bien. En l'occurrence j'ai bien un onglet "Liste de jeux" donc ça passait parfaitement. Ce code est tellement génial que je suis en train de le réutiliser un peu partout dans mon fichier. J'attends encore quelques jours au cas où j'aurais un problème et ensuite je viendrais fermer la discussion. Encore merci merci merci.

 

[Dudu2]

Bonjour,
J'ajouterais cette ressource:

VBA - Importer une image dans une feuille

Dans le fichier à télécharger le Module_ImportImage est à placer dans le Projet VBA. Il fournit une Function ImportImage() dont les paramètres sont décrits dans le code et qui permet de placer dans une plage d'une feuille, une image dont la...

excel-downloads.com

Mais évidemment si tu ne connais RIEN au VBA, c'est comme essayer de piloter un avion sans avoir été formé.

 

[Lu76Fer]

Merci, ça fonctionne super bien. En l'occurrence j'ai bien un onglet "Liste de jeux" donc ça passait parfaitement. Ce code est tellement génial que je suis en train de le réutiliser un peu partout dans mon fichier. J'attends encore quelques jours au cas où j'aurais un problème et ensuite je viendrais fermer la discussion. Encore merci merci merci.

Merci d'avoir partagé ce sujet j'ai appris une astuce très intéressante pour récupérer le nom de l'onglet sur la feuille et du coup créer un événement sur un changement de nom de l'onglet en écrivant une fonction utilisateur :

=STXT(CELLULE("filename";A1);TROUVE("]";CELLULE("filename";A1))+1;255)

Je ne connaissais pas non plus le 'paramétrage d'exécution' avec Application.Volatile et je ne suis pas sûr que je l'utiliserais car trop contraignant et utilisant trop de ressource.