Lien image perdu

Le 03/01/2018 à 10:03

Bonjour à tous,

Je vous souhaite une excellente année 2018 !

J'ai une petite question, j'ai ma macro pour insérer des visuels dans mon fichier :

Sub InsererPic1()
Dim snom As String
Dim i As Long
Dim Emplacement As Range
' Boucle pour balayer les lignes 2 à 10
For i = 2 To 10
    ' Définir le nom de l'image à insérer
    snom = Range("A" & i).Value
    ' Se placer dans la cellule
     Range("B" & i).Select
    Rows(i & ":" & i).RowHeight = 80
    Set Emplacement = ActiveCell.MergeArea
    ' Insérer l'image
    ActiveSheet.Pictures.Insert(snom & ".jpg").Select
    ' Modification de la hauteur de la ligne
    With Selection.ShapeRange
        .Left = Emplacement.Left
        .Top = Emplacement.Top
        .LockAspectRatio = msoTrue
        .Height = Emplacement.Height
    End With
 Next i
End Sub

Petit problème, si j'envoie le fichier à quelqu'un, les images sont remplacés par des croix rouges, il manque les liens.

Sauf que je ne souhaite pas envoyer tout un dossier avec le fichier Excel et les images à part, je souhaite que les images soient juste dans le fichier Excel.

Est-ce posible svp ?

Le 03/01/2018 à 15:59

MaZ,

Je propose le code suivant :

Sub InsererPic1()
Dim snom As String
Dim i As Long
Dim Emplacement As Range
' Boucle pour balayer les lignes 2 à 10
For i = 2 To 10
    ' Définir le nom de l'image à insérer
    snom = Range("A" & i).Value
    ' Se placer dans la cellule
     Range("B" & i).Select
    Rows(i & ":" & i).RowHeight = 80
    Set Emplacement = ActiveCell.MergeArea
    ' Insérer l'image
    ActiveSheet.Shapes.AddPicture Filename:=snom & ".jpg", linktofile:=msoFalse _
            , savewithdocument:=msoCTrue _
            , Left:=Emplacement.Left _
            , Top:=Emplacement.Top _
            , Height:=Emplacement.Height
 Next i
 end sub
Le 03/01/2018 à 17:15

Bonjour Gérard,

merci mais ça ne fonctionne pas, j'ai le message d'erreur suivant :

Nombre d'arguments incorrect ou affectation de propriété incorrecte.

Cela vient peut être de ma version d'Excel ?

Le 03/01/2018 à 17:41

Désolé MaZ, je n'avais pas percuté que tu es en version MAC 2011. J'ai construit ce code sous Windows 2017.

Présentement, je n'ai malheureusement pas de MAC sous la main...

Le 04/01/2018 à 15:39

J'ai pu essayer sur Excel 2015 sur un PC, et j'ai une erreur 450 Nombre d'arguments incorrect

Le 04/01/2018 à 16:07

Bonjour MaZ,

Peux-tu joindre ton classeur?

Le 04/01/2018 à 17:01

Le voici

Merci

8test-macro.xlsm (8.55 Ko)
Le 04/01/2018 à 17:57

MaZ,

En P.J. ton classeur avec la macro modifiée.

11copie-de-test-macro.xlsm (15.50 Ko)
Le 04/01/2018 à 18:01

NB : Pour mes tests, j'ai collé les images dans un sous-dossier "Images" dans le dossier dans lequel est stocké le classeur.

Dans la macro, tu dois changer "Const cPathImages = " par le dossier qui convient.

Le 09/01/2018 à 15:53

Merci Gérard ça fonctionne bien

Par contre, s'il manque un visuel dans mon dossier, ça met un message d'erreur et la macro s'arrête, y'a t'il un moyen pour que la macro continue et que par exemple ça remplisse la cellule où il n'y a pas d'image en rouge stp ?

Aussi, si j'ai une ligne qui ne contient pas de gencod (une ligne de titre par exemple), la macro s'arrête

Merci de ton aide

Le 09/01/2018 à 16:07

Maz,

Pour répondre à ta demande, une nouvelle version de la macro VBA :

Sub InsererPic1()
    Const cPathImages = "Images"
    Dim sPath As String
    Dim snom As String
    Dim i As Long
    Dim Emplacement As Range
    Dim oFS As Object

    Set oFS = CreateObject("Scripting.FileSystemObject")

    sPath = ThisWorkbook.Path & "\" & cPathImages & "\"

    ' Boucle pour balayer les lignes 2 à 10
    For i = 2 To 6
        ' Définir le nom de l'image à insérer
        snom = Range("A" & i).Value
        ' Se placer dans la cellule
         Range("B" & i).Select
        Rows(i & ":" & i).RowHeight = 80
        Set Emplacement = ActiveCell.MergeArea
        ' Insérer l'image
        If oFS.Fileexists(sPath & snom & ".jpg") Then
            ActiveSheet.Shapes.AddPicture sPath & snom & ".jpg", msoFalse _
            , msoCTrue _
            , Emplacement.Left _
            , Emplacement.Top _
            , Emplacement.Width _
            , Emplacement.Height
        Else
            Emplacement.Interior.Color = vbRed
        End If

    Next i

    'On fait la ménage
    Set oFS = Nothing
End Sub
Le 09/01/2018 à 16:23

Au TOP !!!!!!!!!!!!!!

Mille mercis !!! (Et merci de la part de ma collègue )

Le 25/01/2018 à 15:24

Hello,

J'ai une petite question par rapport à cette macro.

Comment faire pour que le contrôle ne se fasse pas uniquement sur des images en jpg mais également en png, tiff etc... stp ?

Le 25/01/2018 à 23:11

Bonsoir Maz,

Oui, il est possible d'importer d'autres formats d'images. Si elles sont toutes du même format, il suffit de modifier l'extension dans la séquence de la macro où figure ".jpg" :

        ' Insérer l'image
        If oFS.Fileexists(sPath & snom & ".jpg") Then
            ActiveSheet.Shapes.AddPicture sPath & snom & ".jpg", msoFalse _
            , msoCTrue _
            , Emplacement.Left _
            , Emplacement.Top _
            , Emplacement.Width _
            , Emplacement.Height

Si les images n'ont pas toutes le même format, il faut ajouter l'extension qui va bien dans le nom d'image (colonne EAN dans ton exemple) i.e 123465.png/456789.tiff/789456.gif ... et supprimer l'extension ".jpg" dans la même séquence.

Le 26/01/2018 à 09:22

Bonjour,

Ok merci pour ta réponse, je pensais qu'on pouvait ajouter des extensions dans la séquence en fait genre "If oFS.Fileexists(sPath & snom & ".jpg", ".png",".tif") Then

car pour le coup, devoir ajouter les extensions dans la colonne EAN est fastidieux

Le 26/01/2018 à 10:38

Bonjour Maz,

Je comprends ton soucis...

Je ne crois pas que ce que tu proposes soit possible, par contre une nouvelle proposition :

Sub InsererPic2()
    Const cExtensions = "jpg;png;tif;gip"
    Const cPathImages = "Images"
    Dim sPath As String
    Dim snom As String, sEAN As String
    Dim i As Long, iExtension As Long
    Dim Emplacement As Range
    Dim oFS As Object
    Dim booFileOK As Boolean
    Dim aExtensions() As String

    aExtensions = Split(cExtensions)

    Set oFS = CreateObject("Scripting.FileSystemObject")

    sPath = ThisWorkbook.Path & "\" & cPathImages & "\"

    ' Boucle pour balayer les lignes 2 à 10
    For i = 2 To 6
        ' Définir le nom de l'image à insérer
        sEAN = Range("A" & i).Value
        ' Se placer dans la cellule
        Range("B" & i).Select
        Rows(i & ":" & i).RowHeight = 80
        Set Emplacement = ActiveCell.MergeArea

        'Boucle sur l'extension pour trouver l'image
        booFileOK = False
        For iExtension = 0 To UBound(aExtensions)
            If oFS.Fileexists(sPath & snom & "." & aExtensions(iExtension)) Then
                snom = sEAN & "." & aExtensions(iExtension)
                booFileOK = True
            End If
        Next

        If booFileOK Then
            ActiveSheet.Shapes.AddPicture sPath & snom & ".jpg", msoFalse _
            , msoCTrue _
            , Emplacement.Left _
            , Emplacement.Top _
            , Emplacement.Width _
            , Emplacement.Height
        Else
            Emplacement.Interior.Color = vbRed
        End If

    Next i

    'On fait la ménage
    Set oFS = Nothing
End Sub

A tester...

Le 26/01/2018 à 10:58

Oups...MAZ, petite erreur dans ma précédente proposition:

En annule et remplace une nouvelle version :

Sub InsererPic2()
    Const cExtensions = "jpg;png;tif;gip"
    Const cPathImages = "Images"
    Dim sPath As String
    Dim snom As String, sEAN As String
    Dim i As Long, iExtension As Long
    Dim Emplacement As Range
    Dim oFS As Object
    Dim booFileOK As Boolean
    Dim aExtensions() As String

    aExtensions = Split(cExtensions, ";")

    Set oFS = CreateObject("Scripting.FileSystemObject")

    sPath = ThisWorkbook.Path & "\" & cPathImages & "\"

    ' Boucle pour balayer les lignes 2 à 10
    For i = 2 To 6
        ' Définir le nom de l'image à insérer
        sEAN = Range("A" & i).Value
        ' Se placer dans la cellule
        Range("B" & i).Select
        Rows(i & ":" & i).RowHeight = 80
        Set Emplacement = ActiveCell.MergeArea

        'Boucle sur l'extension pour trouver l'image
        booFileOK = False
        For iExtension = 0 To UBound(aExtensions)
            If oFS.Fileexists(sPath & snom & "." & aExtensions(iExtension)) Then
                snom = sEAN & "." & aExtensions(iExtension)
                booFileOK = True
            End If
        Next

        If booFileOK Then
            ActiveSheet.Shapes.AddPicture sPath & snom & ".jpg", msoFalse _
            , msoCTrue _
            , Emplacement.Left _
            , Emplacement.Top _
            , Emplacement.Width _
            , Emplacement.Height
        Else
            Emplacement.Interior.Color = vbRed
        End If

    Next i

    'On fait la ménage
    Set oFS = Nothing
End Sub

Toujours à tester...

Le 26/01/2018 à 11:13

Merci

Je teste ça dans la journée et je te ferai un retour.

Le 26/01/2018 à 14:24

Test effectué. Du coup, ça ne m'insère pas les images et toutes mes cellules sont en rouge

Le 26/01/2018 à 15:27

Maz,

Peux-tu joindre en zip un échantillonnage de tes images?

Rechercher des sujets similaires à "lien image perdu"