XL 2019 Placer ou remplacer une photo .jpg au-dessus de la cellule [B6] contenant du texte à conserver

[Webperegrino]

Bonjour Le Forum,

Pour info : rien d’urgent pour l’aide que vous pourriez porter dans les lignes VBA que vous trouverez en pièce jointe. Je galère dans mes tests depuis deux semaines, je peux encore patienter...

La compression contient :
1 - une petite application (PhotoBénévole_1.xlsm) qui va chercher une photo au format .jpg
2 – le répertoire « TROMBINOSCOPE » contenant les images .jpg
Un changement de prénom en cellule [B4] doit modifier la photo (en haut-gauche) en place et au-dessus du texte de la cellule [B6].

Je maîtrise mal l’expression Wsh.Shapes.AddPicture(File, False, True, 0, 0, [F1].Width, [F1].Height) car l’image n’apparaît pas à l’endroit désiré.
Après deux semaines de recherches et de test dans tous les sens, et malgré une tentative de réduction des lignes de code, le résultat est insatisfaisant :
1 – l’ancienne photo n’est pas retirée,
2 – la nouvelle photo correspondant au prénom placé en (B4] va en [A1] au lieu d’aller dans le coi haut-gauche de [B6],
Le texte de [B6] et les autres images du type .JPG (comme le feu vert mis ici en témoin) doivent bien sûr être conservés (à priori j'ai réussi cela).

Je constate aussi qu’après l’utilisation de la macro le triangle de validation liste de [B4] a tendance à disparaître, malgré la ligne de code spéciale mise en fin de vba. Je n'arrive pas à rectifier cela.

Je serais ravi de recevoir une correction des lignes vba pour que ce fichier fonctionne parfaitement.
Webperegrino

 

[sylvanu]

Bonsoir Webperegrino,
Pas sur d'avoir tout compris. Un essai en PJ avec :
Suppression de l'image

For Each forme In ActiveSheet.Shapes
   If forme.Name Like "Image*" Then forme.Delete
Next forme

Positionnement image en B6 :

Set Sha = Wsh.Shapes.AddPicture(File, False, True, [B6].Left, [B6].Top, [F1].Width, [F1].Height)

PS: Concernant le pb de la liste déroulante, je pense que cela vient de la façon dont vous supprimiez l'image.
Dans ma PJ si vous supprimez la ligne [B4].Validation.InCellDropdown = True le problème n'est plus présent car je pense que ma façon de supprimer l'image est plus précise car basée sur le nom de l'image. ( Par contre pourquoi .... 🙂 )

 

[TooFatBoy]

Bonjour,

Je constate aussi qu’après l’utilisation de la macro le triangle de validation liste de [B4] a tendance à disparaître, malgré la ligne de code spéciale mise en fin de vba. Je n'arrive pas à rectifier cela.

Ledit triangle est considéré comme étant une image, et bien que n'étant pas dans la cellule B6, il est supprimé.

J'ai modifié la macro pour ne plus avoir le problème :

Sub Trombino()
' Origine de la macro :
' #12 - AtTheOne et avec l'apport de Job75
' https://excel-downloads.com/threads/placer-mes-photos-dans-la-colonne-a-a3-a4-etc-jusquen-a99-selon-le-prenom-et-le-nom-colonnes-b-et-c.20087816/
Dim Fso As Object, DC As Object
Dim Wsh As Worksheet, RepTrombi As String
Dim DebNoms As Range, DebPhotos As Range, Cible As Range
Dim Sha As Shape, s As Shape, File As Variant

    Set Wsh = Feuil1 ' C'est la feuille "Liste caissiers"
    Set DebNoms = Wsh.[B2]   ' Première cellule contenant les noms
    Set DebPhotos = Wsh.[E2]
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set DC = CreateObject("Scripting.Dictionary")
    RepTrombi = ThisWorkbook.Path & "\TROMBINOSCOPE"
'
    Application.ScreenUpdating = False
  
    ' PARTIE A
    ' *******************************************************************************
    ' Supprimer l'ancienne photo
    For Each s In ActiveSheet.Shapes
        If Left(s.Name, 9) <> "Drop Down" Then
            If s.TopLeftCell.Address = "$B$6" Then s.Delete
        End If
    Next

    ' PARTIE B
    ' *******************************************************************************
    ' Éventuellement placer la nouvelle photo
    If [L5] = "Avec Photo" Then
        For Each File In Fso.GetFolder(RepTrombi).Files ' Fso.GetFolder([PhotoDir]).Files
            If File.Name = [B4] & " " & [C4] & ".jpg" Then
                ' *******************************************************************************
                ' Avec cette ligne, la photo se place en [B6] mais ne supprime pas la précédente
                Set Sha = Wsh.Shapes.AddPicture(File, False, True, [B6].Left, [B6].Top, [B6:D6].Width, [B6:B7].Height)

                ' *******************************************************************************
                ' Cette ligne ne fonctionne pas
                ' Danger : elle supprime le texte dans [B6]
'                Cells(6, 2) = Fso.getBasename(File) ' Le nom de la photo

                ' *******************************************************************************
                ' Cette ligne ne fonctionne pas
'                PlaceThePictureInCenterRange Cells(6, 2), Shapes.AddPicture(File, False, True, 20, 20, -1, -1), 90

                ' *******************************************************************************
                ' Avec cette ligne, la photo se place se rapproche, avec '400' de [B6] sans aller sur [6]
                ' mais ne supprime pas la photo précédente
'                Set s = Wsh.Shapes.AddPicture(File, False, True, [F1].Top, 400, [F1].Width, [F1].Height)

'                Sha.LockAspectRatio = True ' Proportions conservées

                Set s = Nothing
            End If
        Next
        Set Fso = Nothing ' Libération mémoire
    End If

End Sub

J'ai aussi modifié la largeur et la hauteur de l'image...


[edit]
Le pb du DropDown vient de l'instruction On Error Resume Next.
Il y a bien une erreur qui est remontée parce que le DropDown semble ne pas avoir de .TopLeftCell, mais en raison du Resume Next on passe tout de même à l'instruction suivante, instruction qui supprime ledit DropDown...
[/edit]

 

[sylvanu]

Bonsoir TooFatBoy,
Je ne sais pas ce que cela donne sur votre PC, mais sur le mien c'est pas génial :

Ne serait ce pas plutôt :

Set Sha = Wsh.Shapes.AddPicture(File, False, True, [B6].Left, [B6].Top, [B6].Width, [B6:B7].Height)

 

[TooFatBoy]

Je ne sais pas ce que cela donne sur votre PC, mais sur le mien c'est pas génial

On ne sait pas ce qu'elle veut exactement faire donc, comme signalé précédemment, j'ai modifié la largeur et la hauteur de l'image pour lui montrer comment procéder. Maintenant c'est à elle de donner les dimensions qu'elle veut. 😉

 

[job75]

Bonjour Webperegrino, le forum,

On ne sait pas ce qu'elle veut exactement

Webperegrino est une femme ? Comment l'as-tu su TooFatBoy ?

Pour ce problème AddPicture ne va pas, il faut utiliser Pictures.Insert, le code de la feuille "FICHE" :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B4,L5]) Is Nothing Then Exit Sub
Dim o As Object, chemin$, fichier$
For Each o In Me.DrawingObjects
    If o.TopLeftCell.Address = "$B$6" Then o.Delete
Next o
chemin = ThisWorkbook.Path & "\TROMBINOSCOPE\"
fichier = Dir(chemin & [B4] & "*" & [C4] & ".jpg")
If LCase([L5]) = "sans photo" Or fichier = "" Then Exit Sub
With Me.Pictures.Insert(chemin & fichier)
    .ShapeRange.LockAspectRatio = msoTrue 'verrouille le ratio
    .Top = [B6].Top
    .Left = [B6].Left
    .Height = [B6:B7].Height
End With
End Sub

Nota : dans le nom du fichier "Kevin COSTNER.jpg" il y a 2 espaces, c'est pour ça que j'utilise l'astérisque *...

A+

 

[job75]

Bon on peut utiliser AddPicture :

With Me.Shapes.AddPicture(chemin & fichier, msoFalse, msoTrue, [B6].Left, [B6].Top, -1, -1)
    .LockAspectRatio = msoTrue 'verrouille le ratio
    .Height = [B6:B7].Height 'redimensionne l'image
End With

-1 indique que l'on conserve les dimensions originales de l'image.

 

[Webperegrino]

Bonjour Le Forum, Sylvanu, TooFatBoy, Job75,
Merci pour vos belles propositions correctives.

Sylvanu #2
La correction des lignes vba est efficace pour placer la photo en [B6].
La feuille n’est pas « nettoyée » avant toute nouvelle arrivée de photo : les images précédentes restent sous la nouvelle photo

TooFatBoy #3
Avec la proposition de correction Sylvanu résout le problème de largeur de la photo au-dessus de [B6] (largeur constante ou largeur prédéfinie par celle de [F1] par exemple et cette information mise dans la ligne selon ceci, et alors tout fonctionne parfaitement dans la proposition de TooFatBoy :

Set Sha = Wsh.Shapes.AddPicture(File, False, True, [B6].Left, [B6].Top, [F1].Width, [F1].Height)

TooFatBoy, excellent l’ajout de :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target = Range("B4") Then Call Trombino
End Sub

Job 75 :
Bien vu Job ; avant de vous lire, je me m’étais pas rendu compte qu’il fallait supprimer le deuxième espace entre Kevin et COSTNER
Pour rassurer TooFatBoy, ma 23ième paire de chromosomes est bien du type XY.
Job a gagné sur ce coup en #6 !
Tant la proposition Pictures.Insert que celle avec AddPicture fonctionne : je suis impressionné par la conception vba (peu de lignes pour obtenir ce beau résultat)
Merci Job, pour l’ajout #28 d’il y a 18 minutes dans le fil créé le 26/07/2025, à partir des lignes vba duquel j’essayais depuis deux semaines d’appliquer une photo sur [B6] uniquement.

(ajout #28) :

Set s = .Shapes.AddPicture(chemin & fichier, msoFalse, msoTrue, 0, .Rows(lig).Top, -1, -1)
‘-1 pour conserver les dimensions de l'image originale.

Conclusion :
Merci à vous trois pour cette pédagogie lorsque je survole vos différentes propositions.
C’est très intéressant,

Maintenant, un dilemme pour moi : impossible de marquer en vert LA Solution : vos trois solutions sont bonnes et je n'ai pas d'alternative de cocher en vert vos trois # !
Cordialement,
Webperegrino

 

[sylvanu]

Re,

La feuille n’est pas « nettoyée » avant toute nouvelle arrivée de photo : les images précédentes restent sous la nouvelle photo

Etes vous sur de cela ?
Je viens de retester, la photo précédente est bien nettoyée.

 

[Webperegrino]

Sylvanu,
Voici ce que j'obtiens en déplaçant les dernières photos (pièces jointe).
Je recharge l'application du #2 pour re-vérifier que vous avez raison ; à tout de suite.
Webperegrino

 

[Webperegrino]

Sylvanu,
Oui c'est étrange, je viens d'appliquer et j'ai ceci.
Webperegrino

 

[sylvanu]

Re,
Juste une question : Votre Excel est en Français ou en Anglais ?
Car je cherche "Image xx", si c'est en anglais c'est "Picture xx". Ca expliquerait, et je n'y avais pas pensé.

 

[job75]

La suppression des Shapes avec la méthode de sylvanu ne se fait pas pour la raison suivante :

- le nom de l'image affiché en haut à gauche est Image 1, Image 2, Image 3... la langue de l'interface Excel est utilisée

- alors que le nom VBA (Name) est Picture 1, Picture 2, Picture 3... l'anglais est utilisé.

 

[sylvanu]

- alors que le nom VBA (Name) est Picture 1, Picture 2, Picture 3... l'anglais est utilisé.

J'ai évidemment testé, Job. Et ça marche si XL est en Français :

 

[Webperegrino]

Sylvanu,
J'ai vérifié : version .0, en français.
Avec les applications de TooFatBoy et de Job75, je n'ai pas cette réaction. Elles suppriment bien la photo précédente.
Webperegrino