VBA Image via url internet

Le 01/09/2021 à 10:02

Bonjour à tous,

J'ai récupéré plusieurs codes VBA que j'ai assemblés (ouhhh pas bien mais je ne connais pas trop le VBA, juste des notions en html et php ^^) afin de pouvoir faire ceci :

Dans ma cellule A1 si j'insère l'URL d'une image, cette dernière va apparaître 2 cellules plus à droite en supprimant au passage la précédente.
Tout fonctionne très bien jusque la.

Cependant, j'ai voulu rendre automatique la macro pour qu'elle se déclenche dès qu'une cellule est modifiée, à savoir toujours la A1 et ca fonctionne très bien également SAUF si je viens à y mettre autre chose qu'une URL d'une image, dans ce cas un message d'erreur apparait et excel plante carrément :

Erreur d'exécution '1004':
La méthode 'Range' de l'objet '_Worksheet" a échoué

C'est peut être l"histoire d'une boucle infinie ou je ne sais quoi mais je me dis que la solution pour éviter que, quand la case A1 contient autre chose qu'une URL cela plante, n'est pas très loin ! Pourtant si je lance la macro manuellement par un Sub Afficher_Image() par exemple pas de bug si A1 n'est pas conforme, cela marque juste 'Photo non dispo' comme demandé

Pourtant je pensais que cette partie suffit non ? :

If URLValid(cel.Value) = 0 Or HttpExists(cel.Value) = 0 Then
           cel.Offset(0, 2).Value = "Photo non dispo"

Sinon voilà le code entier :

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim Img As Object
For Each Img In ActiveSheet.Pictures
    Img.Delete
Next Img
       Range("A1").Select
 For Each cel In Selection
        cel.Offset(0, 2).Select
        cel.Offset(0, 2).RowHeight = 409
        cel.Offset(0, 2).ColumnWidth = 60

        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
    Range("A1").Select

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

Je termine juste par préciser pourquoi je veux que cela soit automatique sans lancer la macro manuellement. C'est parce que c'est une base de données d'images de légumes. Et pour les expositions afin de monter aux visiteurs sur écran, j'ai une liste de codes barres avec moi avec des URL dans un classeur excel associé à chaque code barre. Tout est paramétré pour que si je scanne avec une douchette laser cela complète automatiquement la case A1 de ma feuille. Donc pour gagner du temps j'ai mis : Private Sub Worksheet_Change(ByVal Target As Excel.Range pour éviter de déclencher la macro à chaque fois que je scanne, car je vais le faire des centaines de fois dans la journée ! Hors cela semble justement ca qui pose problème. Et comme des fois le scan déconne, j'aimerai pas que tout plante.

J'espère avoir été clair et pouvoir résoudre ce problème !
Merci beaucoup d'avance.

Le 01/09/2021 à 11:57

bonjour,

sur quelle ligne reçois-tu ce message d'erreur ?

sinon voici une proposition de correction (non testée)

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
if target.row <>1 or target.column <>1 then exit sub
application.enableevents=false
Dim Img As Object
For Each Img In ActiveSheet.Pictures
    Img.Delete
Next Img
       Range("A1").Select
 For Each cel In Selection
        cel.Offset(0, 2).Select
        cel.Offset(0, 2).RowHeight = 409
        cel.Offset(0, 2).ColumnWidth = 60

        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
    Range("A1").Select
application.enableevents=true
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
Le 01/09/2021 à 13:39

Merci pour la réponse !
j'ai réussi je pense à contourner le problème en insérant au début ce code

If IsNumeric(Range("A1")) Then
LigneVide = Cells(Rows.Count, "E").End(xlUp).Row + 1
Range("E" & LigneVide).Select
Exit Sub
End If

La colonne E c'est la que je scanne mes codes barres.
Et en plus de ce code j'ai demandé à la cellule A1 d'afficher 1 si l'URL n'a pas été trouvé selon le code barre. Ainsi si le code barre est mal lu ou affiche de symboles étranges comme des fois(rarement) cela fait, la cellule A1 aura 1 pour valeur. Comme c'est du numérique, le Exit sub s'appliquera.
J'ai caché toute la colonne A pour éviter que du texte manuel ne soit placé car là ca bloque mais excel ne crashe plus...

Rechercher des sujets similaires à "vba image via url internet"