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, RépTrombi As String
Dim DébNoms As Range, DébPhotos As Range, Cible As Range
Dim Sha As Shape, s As Shape, File As Variant

    Set Wsh = Feuil1 'c'est la Sheets("Liste caissiers")
    Set DébNoms = Wsh.[B2]   'première cellule contenant les noms
    Set DébPhotos = Wsh.[E2]
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set DC = CreateObject("Scripting.Dictionary")
    RépTrombi = ThisWorkbook.Path & "\TROMBINOSCOPE"
'
    Application.ScreenUpdating = False
 
    ' PARTIE A
    ' *******************************************************************************
    ' Supprimer l'ancienne photo quand le prénom [B4] est changé
    For Each s In ActiveSheet.Shapes
        On Error Resume Next
        If Left(s.Name, 9) <> "Drop Down" Then
            If Not Application.Intersect(s.TopLeftCell, ActiveSheet.[B6]) Is Nothing Then
                s.Delete
                On Error GoTo 0
            End If
        End If
    Next

    ' PARTIE B
    ' *******************************************************************************
    ' placer la photo
    If [L5] = "Avec Photo" Then
'        Application.ScreenUpdating = False
        For Each File In Fso.GetFolder(RépTrombi).Files 'Fso.GetFolder([PhotoDir]).Files
            If File.Name = [B4] & " " & [C4] & ".jpg" Then
                ' *******************************************************************************
                ' Avec cette ligne, la photo se place en [A1] 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 photoprécédente
'                Set s = Wsh.Shapes.AddPicture(File, False, True, [F1].Top, 400, [F1].Width, [F1].Height)

'                Sha.LockAspectRatio = True 'proportions concervées

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

'    Application.ScreenUpdating = True

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...

D'une part, pourquoi mettre le Resume Next dans la boucle ?
D'autre part, à quoi ce Resume Next est-il censé servir ?

[/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. 😉