Boucle pour insérer photo dans commentaire

Bonjour à tous, et joyeuses fêtes !

Je joins un classeur avec un code qui permet d'ajouter une image dans un commentaire

Cependant j'aimerais le modifier pour l'intégrer dans une boucle.

il faudrait remplacer l'ouverture de la boite de dialogue pour le choix de l'image et

qu'a la place il sectionne une image en utilisant la valeur de la cellule ou l'on ajoute l'image comme nom de fichier à aller chercher dans un répertoire donné.

Et ce pour toute les cellules de la colonne A,

il faut également prévoir le cas ou l'image n'éxiste pas qu'il passe a la prochaine cellule de la colonne

Par exemple la cellule A4 a pour valeur "Désert",

il faudrait que la macro ajoute l'image en commentaire ayant pour chemin C:\Users\Public\Pictures\Sample Pictures\désert.jpg ou bien C:\Users\Public\Pictures\Sample Pictures\désert.gif

dans le classeur joint j'ai pris les images du dossier échantillon image de windows,

Sub Img_dans_Commentaire()
     With Application.FileDialog(msoFileDialogFilePicker)
     'Indique qu'il s'ait d'ouvrir un dossier pour y sélectionner un fichier
     .AllowMultiSelect = False 'Un seul Fichier possible
     .InitialFileName = "C:\Users\"
     'Répertoire d'ouverture de la fenetre
     .Filters.Clear 'Annuler les filtres au cas où
     .Filters.Add Description:="Images", Extensions:="*.*", Position:=1
     .Title = "Choix de l'image"
     'Verification au cas ou click sur annul dans la boite + lance la boite
     If .Show = -1 Then thefile = .SelectedItems(1) Else thefile = 0
     End With
     'signaler à la personne qu'aucun fichier n'est choisi :
     If thefile = 0 Then
     MsgBox ("aucun fichier image choisi")
     Exit Sub
     End If
    Dim Commentaire As Comment
    Set Commentaire = ActiveCell.AddComment
    'ActiveCell.Comment.Shape.Fill.UserPicture thefile
    Dim UneForme As Shape
    Set UneForme = Commentaire.Shape
    With UneForme
        .Fill.UserPicture thefile
        .ScaleHeight 1, msoFalse
        .ScaleWidth 1, msoFalse
    End With
 End Sub

Mille mercis pour votre aide

Bonsoir Antoine,

Je propose le code suivant :

Sub Img_dans_Commentaire_New()
    Const cPath = "C:\Images\"
    Dim Commentaire As Comment
    Dim oRange As Excel.Range
    Dim oCell As Excel.Range
    Dim oFS As New Scripting.Filesystemobject
    Dim thefile As String, sPath As String

    Set oRange = ThisWorkbook.Names("Path").RefersToRange
    sPath = oRange.Value

    Set oRange = ThisWorkbook.Names("Liste_Images").RefersToRange

    For Each oCell In oRange
        thefile = sPath & Trim(oCell.Value) & ".jpg"
        If oFS.FileExists(thefile) Then
            On Error Resume Next
            oCell.Comment.Delete
            On Error GoTo 0
            Set Commentaire = oCell.AddComment
            Dim UneForme As Shape
            Set UneForme = Commentaire.Shape
            With UneForme
                .Fill.UserPicture thefile
                .ScaleHeight 1, msoFalse
                .ScaleWidth 1, msoFalse
            End With
        End If
    Next
 End Sub

Pour simplifier, j'ai ajouté 2 plages nommées dans le classeur : Liste_Images et Path.

Je n'ai pas bien compris pourquoi (il va être nécessaire que je regarde ce point) pour que l'image de "Echantillon Images" soit trouvée, il faut que le nom de l'image soit la traduction anglaise...

J'ai supprimé les images dans l'EXCEL renvoyé car il ne passait pas avec toutes les images.

Hello Gérard,

Merci pour ton adorable retour, je regarde et j'essaie de faire fonctionner !

bien à toi,

Super Gérard,

Cela fonctionne magnifiquement bien,

Penses -tu qu'il serait possible d'intégrer cette macro dans un user form,

Qui au déclenchement du clique ouvrirait une première fenêtre qui permette de sélectionner dans une fenêtre Windows (comme msoFileDialogFilePicker mais folder picker en gros) l’accès au dossier d'image (travail fait par le nom "path")

Puis une deuxième fenêtre pour définir par sélection la zone de nom "Liste_Images"

Merci beaucoup si tu peux m'aider à apporter ces modifications,

Le travail est dans tous les cas déjà énorme !

bonne fête !

YAaaahhhaa,

J'ai réussi !

Si jamais tu as un commentaire Gérard n'hésite pas je suis toujours entrain d'apprendre,

J'espere que ce petit code bien malin pourra servir à d'autres !

Sub Img_dans_Commentaire_New()
'ne pas oublier d'activer dans Outils\preference microsoft scripting runtime
    Const cPath = "C:\Images\"
    Dim Commentaire As Comment
    Dim oRange As Excel.Range
    Dim oCell As Excel.Range
    Dim oFS As New Scripting.Filesystemobject
    Dim thefile As String, sPath As String

 ' ActiveWorkbook.Names("path").RefersTo = Application.FileDialog(msoFileDialogFolderPicker)

  Dim diaFolder As FileDialog

    ' Open the file dialog
    Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
    diaFolder.AllowMultiSelect = False
    diaFolder.Show

    Feuil1.Range("A1").Value = diaFolder.SelectedItems(1) & "\"
    Range("A1").Name = "Path"

    Dim Plage As Range
    Set Plage = Application.InputBox("Sélectionnez une plage !", "Sélection de cellules", Type:=8)
     Plage.Name = "Liste_Images"

    'ici path doit correspondre a une cellule à la quelle on donne le nom "Path" (dans le gestionaire de nom),
    'le contenu de la cellule doit contenir le chemin d'accès au dossier avec les photos
    'par soucis d'éfficacité du fichier il faut que les photos soient retraité pour mesurer 200px sur 200px
    'le retraitement photo se fait très bien avec le logiciel Xnview

    Set oRange = ActiveWorkbook.Names("Path").RefersToRange
    sPath = oRange.Value

    'ici liste image doit correspondre a la colone avec les codes SKU, on nome cette colonne "Liste_Images" (dans le gestionaire de nom)
    Set oRange = ActiveWorkbook.Names("Liste_Images").RefersToRange

    For Each oCell In oRange
        thefile = sPath & Trim(oCell.Value) & ".jpg"
        If oFS.FileExists(thefile) Then
            On Error Resume Next
            oCell.Comment.Delete
            On Error GoTo 0
            Set Commentaire = oCell.AddComment
            Dim UneForme As Shape
            Set UneForme = Commentaire.Shape
            With UneForme
                .Fill.UserPicture thefile
                .ScaleHeight 1, msoFalse
                .ScaleWidth 1, msoFalse
                .Height = 200
                .Width = 200
            End With
        End If
    Next

 End Sub