VBA - Afficher erreur message quand url link ne fonctionne pas

Le 03/12/2022 à 17:08

Bonjour Forum -

Long time no speak here et merci encore pour votre aide au fil des annees !

J'utilise un code vba tres simple qui me permet d'afficher des photos dans un range en utilisant la cellule situee au dessus ou le lien url de la photo se situe.

Malheuresement qq fois le lien url ne fonctionne pas car il n'y pas de photo, j'aimerai donc afficher dans la cellule = Pas de Photo Disponible !

Merci d'avance

Dim pic As String
Dim myPicture As Picture
Dim rng As Range
Dim item As Range

Set rng = Range("B11:AA11")
For Each item In rng
    pic = item.Offset(-1, 0)
    If pic = "" Then Exit Sub

        Set myPicture = ActiveSheet.Pictures.Insert(pic)

        With myPicture
            .ShapeRange.LockAspectRatio = msoFalse
            .Width = item.Width
            .Height = item.Height
            .Top = Rows(item.Row).Top
            .Left = Columns(item.Column).Left
            .Placement = xlMoveAndSize
        End With

    Next
End Sub

Le 03/12/2022 à 18:25

Bonsoir kouyotj

Vous pouvez essayer ceci avec une fonction qui teste le lien

Sub Test()
  Dim pic As String
  Dim myPicture As Picture
  Dim rng As Range
  Dim item As Range

  Set rng = Range("B11:AA11")
  For Each item In rng
    pic = item.Offset(-1, 0)
    If pic = "" Then Exit Sub
    ' Vérifier si URL OK
    If Not URLExist(pic) Then
      item.Value = "Pas d'image"
    Else  ' Si OUI
      Set myPicture = ActiveSheet.Pictures.Insert(pic)
      With myPicture
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = item.Width
        .Height = item.Height
        .Top = Rows(item.Row).Top
        .Left = Columns(item.Column).Left
        .Placement = xlMoveAndSize
      End With
    End If
  Next
End Sub

Function URLExist(url As String) As Boolean
    Dim Request As Object
    Dim rc As Variant
    On Error GoTo EndNow
    Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
    With Request
      .Open "GET", url, False
      .Send
      rc = .StatusText
    End With
    Set Request = Nothing
    If rc = "OK" Then URLExist = True

    Exit Function
EndNow:
End Function

A+

Le 07/12/2022 à 20:38

Bonjour - malheuresement le lien https qui est en B10 par example ou C10 pour la seconde photo, m'affiche pas d'image alors que ce n'est pas le cas.

Le lien est par example : https://www.johnlewis.com/school-unisex-jogging-bottoms-dark-green/p3883226

Le 09/12/2022 à 10:27

Bonjour louyotj

En fait, je ne suis pas certain que ce soit faisable pour une page

Si vous essayez https://www.johnlewis.com/school-unisex-jogging-bottoms-dark-green/p3883226/toto

Vous tomber bien sur une page... sauf que c'est la 404

A+

Le 09/12/2022 à 10:55

Merci Bruno pour l'investigation.