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

B

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
 
Trier par date Trier par votes
fanch55

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 .....
 
Vote positif 0 Vote négatif
Hasco

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
 
Vote positif 0 Vote négatif
fanch55

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
Vote positif 0 Vote négatif
B

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...
 
Vote positif 0 Vote négatif
I

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:
Vote positif 0 Vote négatif
fanch55

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:
Vote positif 0 Vote négatif
I

isramail

XLDnaute Nouveau
fanch55 à dit:
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
Cliquez pour agrandir...
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 .
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
isramail à dit:
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 .
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif

Discussions similaires

cathodique
  • Résolu(e)
XL 2010 Module de classe avec Dictionary
3 4 5
Réponses
66
Affichages
3 K
patricktoulon
patricktoulon
patricktoulon
  • Question
XL 2013 enregistrer la capture d'une shape avec les api avec transparence
2
Réponses
26
Affichages
916
patricktoulon
patricktoulon
A
  • Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
137
patricktoulon
patricktoulon
E
  • Question
Microsoft 365 Excel VBA
Réponses
5
Affichages
326
Excellearning
E
ralph45
  • Question
Microsoft 365 [VBA] Listes déroulantes à choix multiples sur N colonnes discontinues
Réponses
4
Affichages
555
ralph45
ralph45
patricktoulon
  • Question
Autres la fonction similaire
Réponses
11
Affichages
433
patricktoulon
patricktoulon
T
  • Question
XL 2016 Erreur d'exécution 1004 : Impossible de définir la propriété Hidden de la classe Range
Réponses
3
Affichages
311
Phil69970
Phil69970
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
648
crocrocro
C
J
  • Résolu(e)
XL 2021 génération de QR code
Réponses
4
Affichages
845
JPaul78
J
Nicolas JACQUIN
  • Question
XL 2021 Exportation module, erreur après déprotection
2
Réponses
20
Affichages
1 K
Dranreb
Dranreb

Membres actuellement en ligne

4 membres et 73 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 098
Messages
2 116 190
Membres
112 679
dernier inscrit
Yupanki