Ameliorer une macro insertion image

Bonjour,

Et tu veux qu'on fasse quoi sans la macro du fichier ?

Pour garder les photos dans un fichier transmis, il faut envoyer le dossier photos et mettre le chemin de l'acquéreur.

Cdt

Bonjour et

Tu devrais mettre le code qui t'a été fait

ou mieux le fichier sans info confidencielles/personnelles

1) peut etre réglé en utilisant la fonction "dir"

2) Tu dis que :

les photos recuperees dans un répertoire sur mon pc

Avec des photos sur le réseau plutot que sur ton ordinateur, chaque utilisateur aura accés a ces photos.

A+

Edit : En retard de peu, bonjour fronck

bonjour

ci joint le fichier et le code

mes photos sont sur réseau donc tous mes collègues ayant accès a ce réseau voient bien les images mais je souhaiterai que des clients n'ayant pas accès ace dernier puissent également les voir

merci de votre aide en tout cas

Sub LinkToImage()

    Range("I7").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ' les lignes du haut selectionnent les cellules contenant la concatenation (1)

    Range("J7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        'colle en tant que valeur les resultats de la formule concatennee (2)

Range("J7").Select
' selectionne les cellules collees (2) en tant que valeur

    Range(Selection, Selection.End(xlDown)).Select

    For Each cel In Selection
        cel.Offset(0, -9).Select
        cel.Offset(0, -9).RowHeight = 100
        cel.Offset(0, -9).ColumnWidth = 40
     'ajuste la taille des cellules ou seront collees les photos

        Set image = ActiveSheet.Pictures.Insert(cel.Value)

        With image
            .ShapeRange.LockAspectRatio = msoTrue
            .Width = cel.Offset(0, -9).Width
            .Height = cel.Offset(0, -9).Height
            .Left = cel.Offset(0, -9).Left
            .Top = cel.Offset(0, -9).Top
            '-9 correspond au decalage de l'image ( ici en colonne 1)par rapport au chemin d acces ici en colonne 10 (ramene a 9)

        End With

    Next cel

    End Sub

Bonjour,

A tester :

A+

Bonjour Geof52

merci pour le fichier mais j'ai l’impression que cela ne fonctionne pas

le bouton supprimer toutes les images c'est bon

le bouton insérer image c'est bon mais je suis toujours confrontée aux mêmes problèmes, a savoir qu'en mettant un article dont la photo n'existe pas dans le répertoire, la macro s’arrête et j'ai le message

erreur exécution 1004

le fichier spécifié est introuvable

Private Sub AjoutImage_Click()

    Range("I7").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ' les lignes du haut selectionnent les cellules contenant la concatenation (1)

    Range("J7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        'colle en tant que valeur les resultats de la formule concatennee (2)

Range("J7").Select
' selectionne les cellules collees (2) en tant que valeur

    Range(Selection, Selection.End(xlDown)).Select

    For Each cel In Selection
        cel.Offset(0, -9).Select
        cel.Offset(0, -9).RowHeight = 100
        cel.Offset(0, -9).ColumnWidth = 40
     'ajuste la taille des cellules ou seront collees les photos

        NomArticle = cel.Offset(0, -8).Value
        ActiveSheet.Shapes.AddPicture(cel.Value, False, True, cel.Offset(0, -9).Left, cel.Offset(0, -9).Top, -1, -1).Name = NomArticle
        With ActiveSheet.Shapes.Range(Array(NomArticle))
            .LockAspectRatio = msoTrue
            .Width = cel.Offset(0, -9).Width
            .Height = cel.Offset(0, -9).Height
        End With

    Next cel
End Sub

Private Sub SuppAllImage_Click()
'Supprimer toutes les images (sans les boutons)
For Each PicShape In ActiveSheet.Shapes
    If PicShape.Type = msoPicture Then PicShape.Delete
Next PicShape
End Sub

c'est cette ligne qui se met en jaune

ActiveSheet.Shapes.AddPicture(cel.Value, False, True, cel.Offset(0, -9).Left, cel.Offset(0, -9).Top, -1, -1).Name = NomArticle

de plus, lorsque j'envoie le fichier a une autre personne (n'ayant pas accès au répertoire de mes photos en réseau); les photos ne sont pas visibles.

quelque chose m’échappe mais je ne voie pas quoi, ( le langage vba n'étant clairement pas pour moi)

Normal pour l'image qui n'existe pas, j'ai zappé cette partie de la consigne .

Essai avec ça : (pour les articles sans images) => If Dir(cel.Value) <> "" Then ... end if

Private Sub AjoutImage_Click()
Application.ScreenUpdating = False
    Range("I7").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ' les lignes du haut selectionnent les cellules contenant la concatenation (1)

    Range("J7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        'colle en tant que valeur les resultats de la formule concatennee (2)

Range("J7").Select
' selectionne les cellules collees (2) en tant que valeur

    Range(Selection, Selection.End(xlDown)).Select

    For Each cel In Selection
        cel.Offset(0, -9).Select
        cel.Offset(0, -9).RowHeight = 100
        cel.Offset(0, -9).ColumnWidth = 40
     'ajuste la taille des cellules ou seront collees les photos

        NomArticle = cel.Offset(0, -8).Value
        If Dir(cel.Value) <> "" Then
            ActiveSheet.Shapes.AddPicture(cel.Value, False, True, cel.Offset(0, -9).Left, cel.Offset(0, -9).Top, -1, -1).Name = NomArticle
            With ActiveSheet.Shapes.Range(Array(NomArticle))
                .LockAspectRatio = msoTrue
                .Width = cel.Offset(0, -9).Width
                .Height = cel.Offset(0, -9).Height
            End With
        End If

    Next cel
Application.ScreenUpdating = True
End Sub

Private Sub SuppAllImage_Click()
'Supprimer toutes les images (sans les boutons)
For Each PicShape In ActiveSheet.Shapes
    If PicShape.Type = msoPicture Then PicShape.Delete
Next PicShape
End Sub

Pour l'image qui n'apparait pas chez une personne externe au reseau, je ne vois pas pourquoi ?

Tu as bien eu les images banane / pomme / orange sur mon dernier fichier ou elles n'etaient pas visible ?

oui elles étaient bien visibles, c'est pour ca que je ne comprends pas pourquoi j'arrive a voir tes photos et que les miennes n'apparaissent pas

Pour info, c'est l'insertion de l'image que j'ai modifié en ajout d'image

ActiveSheet.Pictures.Insert

ActiveSheet.Shapes.AddPicture

Donc tes images maintenant devraient fonctionner pour les gens hors reseau (tu peux me faire un fichier retour avec tes deux lignes "ABABO_PO et BENTO_PO" si tu le souhaites)

Petit bonus : Si tu t'interesse aux macro, je n'ai pas touché au reste du code mais il y a moyen de rendre cela "plus lisible" a mon sens.

genial, ca fonctionne pour ce qui est de continuer la macro meme si une photo n'existe pas

et j'ai envoyé le fichier a une personne extereiure pour test

voici sa réponse

"si on appuie juste sur la pièce jointe on ne voit pas les photos mais si on fait ouvrir avec google sheets on voit les photos "

merci Geof52

je remet ici mon fichier, j'y ai ajouté quelques articles pour que l'on puisse voir que la condition du " je continue même si la photo n'existe pas" fonctionne bien

dans mon boulot, je passe 50% de mon temps sur excel , alors bien évidemment que les macros m'interressent et j'ai fait une mini formation mais comme on m'a répondu, on n'apprend pas en 16h ce que d'autres apprennent en 4 ans

j'ai donc vite déchanté mais là pour le coup, tu viens de me faire gagner un temps considérable, ( enfin si tu me confirmes que tu reçois bien mon fichier avec les photos)

J'ai bien les photos,

Pour le temps que tu viens de gagner, tu peux jetter un oeil sur les deux onglets en haut de la page :

Cours VBA et Fonction VBA, une mine d'or si tu souhaites automatiser ta façon de travailler.

Comme amélioration, tu pourrais mettre le lien de tes photos a l'intérieur de la macro ("X:\Documents F\PHOTO POUR MACRO\")
J'essai de te faire un exemple dans la journée.

A+

houlala, je ne te remercierai jamais assez

j'attends ta touche finale alors avant de mettre en résolu et je ne manquerai pas de jeter un coup d’œil aux 2 onglets

que tu as mentionné

Voila une autre façon de faire sans offset et sans emplacement de fichier visible sur ton classeur.

Option Explicit

Private Sub AjoutImage_Click()
Dim EmpImage, AdresseImage, NomArticle As String
Dim DerLigArticle, RefArticle As Integer
Application.ScreenUpdating = False
Range("A:A").ColumnWidth = 40

EmpImage = "X:\Documents F\PHOTO POUR MACRO\"

DerLigArticle = Cells(Rows.Count, 2).End(xlUp).Row

For RefArticle = 7 To DerLigArticle
    NomArticle = Cells(RefArticle, 2).Value
    AdresseImage = EmpImage & NomArticle & ".jpg"

    If Dir(AdresseImage) <> "" Then
        Rows(RefArticle).RowHeight = 100
        Shapes.AddPicture(AdresseImage, False, True, Cells(RefArticle, 1).Left, Cells(RefArticle, 1).Top, -1, -1).Name = NomArticle
        With Shapes.Range(Array(NomArticle))
            .LockAspectRatio = msoTrue
            .Width = Cells(RefArticle, 1).Width
            .Height = Cells(RefArticle, 1).Height
        End With
    End If

Next RefArticle

Application.ScreenUpdating = True
End Sub

Private Sub SuppAllImage_Click()
Dim PicShape As Object
'Supprimer toutes les images (sans les boutons)
For Each PicShape In ActiveSheet.Shapes
    If PicShape.Type = msoPicture Then PicShape.Delete
Next PicShape
End Sub

A+

bonjour Geof52

je tiens vraiment a te remercier pour le temps passé a ma macro qui fonctionne super bien

je vais continuer de tenter d'autres choses pour l’améliorer encore plus

(je n'ai pas pensé a tout lorsque j'ai lancé ma bouteille a la mer )

merci encore et belle journée a toi