" this image cannot currently be displayed" from excel to adobe icloud

[jc83ph]

hi guys,

I need your help to fix this code.

This code is work and I get this code from this site, only the issue is the pictures not showing.

See below the result and VBA code.

in sheet:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim shp As Shape
  Dim rng As Range, c As Range
  Dim img As String, imgName As String
 
  Const filepath As String = "https://assets.adobe.com/public/a035cb43-3ac8-4127-5e23-83e0614f81bd/"
 
  Application.ScreenUpdating = False
  Set rng = Intersect(Target, Range("C2:C" & Rows.Count))
  If Not rng Is Nothing Then
    For Each c In rng
      With c.Offset(0, -1)
        imgName = "PictureAt" & .Address
        On Error Resume Next
          Me.Shapes(imgName).Delete
        On Error GoTo 0
      
        'If URLCheck(filepath & "NOPHOTO.jpg") <> False Then img = filepath & "NOPHOTO.jpg"
        If URLCheck(filepath & c.Value & ".jpg") <> False Then img = filepath & c.Value & ".jpg"
        ' test
        If URLCheck(filepath & c.Value & ".jpg") <> False Then img = filepath & c.Value & ".jpg"
      
        If img <> "" Then
          Set shp = Me.Shapes.AddPicture(img, msoFalse, msoTrue, .Left, .Top, 200, 200)
          shp.Name = imgName
          shp.ScaleHeight 1, msoTrue
          shp.ScaleWidth 1, msoTrue
          shp.LockAspectRatio = msoTrue
          shp.Height = c.Cells(1).Height - 4
          shp.Left = .Left + ((.Width - shp.Width) / 2)
          shp.Top = .Top + ((.Height - shp.Height) / 2)
        End If
      End With
    Next
  End If
  Application.ScreenUpdating = True
End Sub

in module

Function URLCheck(url As String) As Boolean
    Dim Request As Object
    Dim ff As Integer
    Dim rc As Variant
     url = Replace(url, " ", "&20")
    On Error GoTo EndNow
    Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")

    With Request
      'new
      .Option(0) = "Echovoice VBA HTTP Bot v0.1"
 
      .Open "GET", url, False
      .Send
      rc = .StatusText
      'new
      rd = .Status & " " & Left(.responseText, 160)
    
    End With
 
    Set Request = Nothing
 
    If rc = "OK" Then URLCheck = True
    'new
    Debug.Print rd; vbLf; rc; vbLf; url; vbLf ' look at immediate window CrtL+G
 
    Exit Function
EndNow:
End Function

Please i need your help.

 

[Fluff]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: help for fix the code for the result of picture " this image cannot currently be displayed
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.