XL 2010 Erreur 1004 : Impossible de lire la propriété Insert de la classe Pictures

Baroukar

XLDnaute Nouveau
Bonjour à tous,

Voici mon problème, j'ai un macro pour transformer tous mes liens URL en image sur mon excel, le macro fonctionne très bien sur mon ordi (où j'ai la version Excel 2010) mais dès que je l'envoie à des collègues possédant la version Excel 2019, un message d'erreur s'affiche : "Erreur d'exécution '1004' : Impossible de lire la propriété Insert de la classe Pictures".

Voici le macro :

VB:
Sub LienImage()

    For Each cel In Selection
        cel.Offset(0, 1).Select
        cel.Offset(0, 1).RowHeight = 200
        cel.Offset(0, 1).ColumnWidth = 80

        If URLValid(cel.Value) = 0 Or HttpExists(cel.Value) = 0 Then
           cel.Offset(0, 1).Value = "Photo non dispo"
        Else
            Set Image = ActiveSheet.Pictures.Insert(cel.Value)
            With Image
                .ShapeRange.LockAspectRatio = msoTrue
                .Width = cel.Offset(0, 1).Width
                .Height = cel.Offset(0, 1).Height
                .Left = cel.Offset(0, 1).Left
                .Top = cel.Offset(0, 1).Top
            End With
        End If
    Next cel

End Sub

Function URLValid(url As String) As Boolean
    If InStr(url, "png") > 0 Then
        URLValid = True
    ElseIf InStr(url, "jpg") > 0 Then
        URLValid = True
    ElseIf InStr(url, "jpeg") > 0 Then
        URLValid = True
    ElseIf InStr(url, "bmp") > 0 Then
        URLValid = True
    Else
        URLValid = False
    End If
End Function

Function HttpExists(ByVal sURL As String) As Boolean
    Dim oXHTTP As Object
    Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
    On Error GoTo haveError
    oXHTTP.Open "HEAD", sURL, False
    oXHTTP.send
    HttpExists = IIf(oXHTTP.Status = 200, True, False)
    Exit Function
haveError:
    Debug.Print Err.Description
    HttpExists = False
End Function

Et quand je fais Débogage il m'indique que c'est cette ligne là qui pose problème :

Code:
Set Image = ActiveSheet.Pictures.Insert(cel.Value)


Merci d'avance !

Baroukar
 

fanch55

XLDnaute Barbatruc
Bonsoir,
D'après le code, vous allez chercher une image sur un hébergeur.
J'ai testé votre code avec l'url gratuite ci-dessous:
VB:
https://previews.123rf.com/images/dotshock/dotshock1801/dotshock180101045/94469587-femme-ing%C3%A9nieur-en-informatique-travaillant-sur-une-tablette-dans-la-salle-des-serveurs-au-centre-de-d.jpg

Tout marche bien, mais je suis en Excel 2016 ( très peu de différence entre 2016 et 2019 ) .

Peut-être un pratiquant d'Excel 2019 pourra vous confirmer le bon/mauvais fonctionnement avec cette adresse .....
 

Hasco

XLDnaute Barbatruc
Repose en paix
Re,

Je vous ai donné le lien vers la page d'aide ms. C'est à moi également d'aller la lire et faire des tests ?

Ceci fonctionne sous 2019 :
VB:
Sub truc()

Const url = "https://previews.123rf.com/images/dotshock/dotshock1801/dotshock180101045/94469587-femme-ing%C3%A9nieur-en-informatique-travaillant-sur-une-tablette-dans-la-salle-des-serveurs-au-centre-de-d.jpg"

ActiveSheet.Shapes.AddPicture _

    url, _

    True, True, 100, 100, 70, 70

End Sub
 

fanch55

XLDnaute Barbatruc
Bonjour à tous,

La version ci-jointe avec le addpicture ( l'autre fonctionne également ) .

Mais je pense que quelle que soit la méthode utilisée, vous pouvez vous heurter à des problèmes de sécurité : soit votre feuille est protégée, soit le pare-feu empêche le téléchargement via l'Url .

Si vous pouviez nous indiquer l'Url qui pêche ( si c'est juste une photo, ce ne devrait pas être trop confidentiel ) .... :rolleyes:
 

Pièces jointes

  • Baroukar.xlsm
    196.4 KB · Affichages: 28

Baroukar

XLDnaute Nouveau
Bonjour,

Je viens d'essayer avec votre excel, cela fonctionne avec les URL que vous aviez déjà mis mais pas avec les miens, je pense que cela doit être dû au fait que mes URL proviennent d'un site qui nécessite une identification. Via Kutools cela fonctionne pourtant...
 

isramail

XLDnaute Nouveau
bonjour a tous!

desolé de déterrer ce post

je tente de faire afficher sur une liste d'url les images qui correspondent sur internet

j'utilise le même code que boubakar sous l'appli windows excel365

celui ci fonctionne correctement mais au bout de quelques lignes parfois 10, parfois 100, parfois 200 la macro s'arrête et affiche la même erreur que boubakar :

"Erreur d'exécution '1004' : Impossible de lire la propriété Insert de la classe Pictures".

VB:
Sub LinkToImage()
For Each cel In Selection
cel.Offset(0, 2).Select
cel.Offset(0, 2).RowHeight = 100
cel.Offset(0, 2).ColumnWidth = 40
DoEvents
If URLValid(cel.Value) = 0 Or HttpExists(cel.Value) = 0 Then
cel.Offset(0, 2).Value = "Photo non dispo"
Else
Set Image = ActiveSheet.Pictures.Insert(cel.Value)
With Image
.ShapeRange.LockAspectRatio = msoTrue
.Width = cel.Offset(0, 2).Width
.Height = cel.Offset(0, 2).Height
.Left = cel.Offset(0, 2).Left
.Top = cel.Offset(0, 2).Top
End With
End If
Next cel
End Sub
Function URLValid(url As String) As Boolean
If InStr(url, "png") > 0 Then
URLValid = True
ElseIf InStr(url, "jpg") > 0 Then
URLValid = True
ElseIf InStr(url, "jpeg") > 0 Then
URLValid = True
ElseIf InStr(url, "bmp") > 0 Then
URLValid = True
Else
URLValid = False
End If
End Function
Function HttpExists(ByVal sURL As String) As Boolean
Dim oXHTTP As Object
Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
On Error GoTo haveError
oXHTTP.Open "HEAD", sURL, False
oXHTTP.send
HttpExists = IIf(oXHTTP.Status = 200, True, False)
Exit Function
haveError:
Debug.Print Err.Description
HttpExists = False
End Function

Lorsque je tente de la relancer la macro ne traite plus qu'une seule ligne et affiche une image puis le message se remet.

Pouvez vous m'aider svp, je suis vraiment novice sur excel et ses macro
 
Dernière édition:

fanch55

XLDnaute Barbatruc
Bonjour,
Ce n'est pas ce code qu'a retenu Boubakar.
Mais vous pouvez tester ce code légèrement transformé :
VB:
Option Compare Text
Sub LinkToImage()
    For Each Cel In Selection.Cells
        If Cel <> "" Then
            With Cel.Offset(0, 2)
                .RowHeight = 100
                .ColumnWidth = 40
                If URLValid(Cel.Value) = 0 Or HttpExists(Cel.Value) = 0 Then
                    .Value = "Photo non dispo"
                Else
                    Name = "Img_" & .Address
                    On Error Resume Next: .Parent.Shapes(Name).Delete: On Error GoTo 0
                    With .Parent.Shapes.AddPicture(Cel.Value, False, True, .Left, .Top, -1, -1)
                        .Name = Name
                        .LockAspectRatio = msoTrue
                        .Width = .TopLeftCell.Width
                        .Height = .TopLeftCell.Height
                        .Left = .TopLeftCell.Left + (.TopLeftCell.Width - .Width) / 2
                    End With
                End If
            End With
        End If
    Next Cel
End Sub
Function URLValid(url As String) As Boolean
    URLValid = True
    Select Case True
        Case url Like "*png"
        Case url Like "*jpg"
        Case url Like "*jpeg"
        Case url Like "*bmp"
        Case Else: URLValid = False
    End Select
End Function
Function HttpExists(ByVal sURL As String) As Boolean
    Dim oXHTTP As Object
    Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
        On Error GoTo haveError
        oXHTTP.Open "HEAD", sURL, False
        oXHTTP.send
        HttpExists = IIf(oXHTTP.Status = 200, True, False)
    Set oXHTTP = Nothing
    Exit Function
haveError:
    Debug.Print Err.Description
    HttpExists = False
End Function
 
Dernière édition:

isramail

XLDnaute Nouveau
Bonjour,
Ce n'est pas ce code qu'a retenu Boubakar.
Mais vous pouvez tester ce code légèrement transformé :
VB:
Option Compare Text
Sub LinkToImage()
    For Each Cel In Selection.Cells
        If Cel <> "" Then
            With Cel.Offset(0, 2)
                .RowHeight = 100
                .ColumnWidth = 40
                If URLValid(Cel.Value) = 0 Or HttpExists(Cel.Value) = 0 Then
                    .Value = "Photo non dispo"
                Else
                    Name = "Img_" & .Address
                    On Error Resume Next: .Parent.Shapes(Name).Delete: On Error GoTo 0
                    With .Parent.Shapes.AddPicture(Cel.Value, False, True, .Left, .Top, -1, -1)
                        .Name = Name
                        .LockAspectRatio = msoTrue
                        .Width = .TopLeftCell.Width
                        .Height = .TopLeftCell.Height
                        .Left = .TopLeftCell.Left + (.TopLeftCell.Width - .Width) / 2
                    End With
                End If
            End With
        End If
    Next Cel
End Sub
Function URLValid(url As String) As Boolean
    URLValid = True
    Select Case True
        Case url Like "*png"
        Case url Like "*jpg"
        Case url Like "*jpeg"
        Case url Like "*bmp"
        Case Else: URLValid = False
    End Select
End Function
Function HttpExists(ByVal sURL As String) As Boolean
    Dim oXHTTP As Object
    Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
        On Error GoTo haveError
        oXHTTP.Open "HEAD", sURL, False
        oXHTTP.send
        HttpExists = IIf(oXHTTP.Status = 200, True, False)
    Set oXHTTP = Nothing
    Exit Function
haveError:
    Debug.Print Err.Description
    HttpExists = False
End Function
Bonjour et merci de votre aide FANCH55 !

votre code a l'air de fonctionner mais il n' accepte pas mes url pour cause: les fichiers et donc la fin des url ont cette forme: ........8072091s.jpg?v=1514380872

pouvez vous svp ajouter une règle qui permette d'accepter ce type d'url / fichiers ?

merci de votre aide .
 

fanch55

XLDnaute Barbatruc
Bonjour et merci de votre aide FANCH55 !

votre code a l'air de fonctionner mais il n' accepte pas mes url pour cause: les fichiers et donc la fin des url ont cette forme: ........8072091s.jpg?v=1514380872

pouvez vous svp ajouter une règle qui permette d'accepter ce type d'url / fichiers ?

merci de votre aide .
VB:
Function URLValid(url As String) As Boolean
    URLValid = True
    Select Case True
        Case url Like "*.png*"
        Case url Like "*.jpg*"
        Case url Like "*.jpeg*"
        Case url Like "*.bmp*"
        Case Else: URLValid = False
    End Select
End Function
 

Discussions similaires

Réponses
6
Affichages
271

Membres actuellement en ligne

Statistiques des forums

Discussions
314 499
Messages
2 110 249
Membres
110 711
dernier inscrit
chmessi