Addpicture check second webpath if first not exist

Question

please help me with below code i have 2 picture paths and i want to addpicture from first path, but if picture not exist macro should check second path. I have problem to code that.

Sub foto()
Dim model As String
Dim http As String
Dim first, second As String
Dim Shp As Shape
   
model = ActiveCell.Value
http = "http://aaa/bbb/"
first = http & model & "-A.jpg"
second = http & model & "-B.jpg"
  
For Each Shp In ActiveSheet.Shapes
    If Shp.Name = "MyPicture1" Then
        Shp.Delete
    End If
Next Shp

    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 160, 220)
        .Name = "MyPicture1"
        .Line.Weight = 0.2
        .Fill.UserPicture first 'first path
        .Top = ActiveCell.Offset(1, 1).Top
        .Left = ActiveCell.Offset(1, 1).Left
    End With

        
End Sub

Do you get a run-time error when the `first` path is not valid? — DecimalTurn, Jul 31 '20 at 21:31
yes i get run-time error, method userpicture of object 'fillformat' failed. — Tomz, Aug 04 '20 at 12:33

score 1 · Accepted Answer · answered Aug 04 '20 at 14:51

I see that the path you have in you code starts with http, so you could test the status response of the URL to see if the image is available.

There is a few status codes, but the only one that really matters here is the code 200 which indicates that the image exists, so we can check for that.

To get the status code of a web page, you can use the following function (inspired by this answer):

Function CheckStatus(ByVal Url As String) As Long

    Dim source As Range, req As Object
    Set req = CreateObject("Msxml2.ServerXMLHTTP.6.0")
    
    'Send the request using a HEAD to check the status line
    req.Open "HEAD", Url, False
    req.setRequestHeader "Accept", "image/webp,image/*,*/*;q=0.8"
    req.setRequestHeader "Accept-Language", "en-US;q=0.8,en;q=0.6"
    req.setRequestHeader "Accept-Encoding", "gzip, deflate"
    req.setRequestHeader "Cache-Control", "no-cache"
    req.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
    req.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.3; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/47.0.2526.111 Safari/537.36"
    req.Send
    
    CheckStatus = req.Status

End Function

Then you could use an if-statement in your code to check for the status and get the good image url:

Sub foto()

    Dim model As String
    Dim http As String
    Dim ImageUrl As String
    Dim Shp As Shape
   
    model = ActiveCell.Value
    http = "http://aaa/bbb/"
    
    If CheckStatus(http & model & "-A.jpg") = 200 Then
        ImageUrl = http & model & "-A.jpg"
    Else
        ImageUrl = http & model & "-B.jpg"
    End If
  
    For Each Shp In ActiveSheet.Shapes
        If Shp.Name = "MyPicture1" Then
            Shp.Delete
        End If
    Next Shp

    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 160, 220)
        .Name = "MyPicture1"
        .Line.Weight = 0.2
        .Fill.UserPicture ImageUrl
        .Top = ActiveCell.Offset(1, 1).Top
        .Left = ActiveCell.Offset(1, 1).Left
    End With
        
End Sub

Thanks man! Somehow i managed to solve the problem but your solution is much simpler and almost dont change my code too much. — Tomz, Aug 05 '20 at 05:46

Addpicture check second webpath if first not exist

1 Answers1