link pictures from Sharepoint to Excel macro

[jc83ph]

Hi,

I need your help to fix this issue. I have a code and this is work on my computer. But now I try to link the picture from the SharePoint to excel macro using the code and path folder.

I try to add the path folder using Sharepoint to excel. But is not work to show the pictures in excel

Here is the example:

here is the code I use

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://li0.sharepoint.com/sites/Lux-Qtr/SC/Stock Pictures/"

  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 Dir(filepath & "NOPHOTO.jpg") <> "" Then img = filepath & "NOPHOTO.jpg"
        If Dir(filepath & c.Value & ".jpg") <> "" 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

Please help me to fix this code. I try many times but still did not work.


Regards,

 

[bbrnx19]

 

[jc83ph]

here

 

[jc83ph]

Hi BBRNX19,

did you see my attached for the result of ctrl+G?

Thanks you advance for your help. I hope you can fix this.

 

[bbrnx19]

Pass - there should be some response - but being blank.

Since for me the example Test address in my previously posted and you have seen worked. An I have checked on two different a machines one running Win 8.1, Excel 2007 and the other Win 10 , Excel 365 .

I conclude that there is something in either your User Profile or your machine system. - only suggestion is for you to check this on a different machine .

Good luck

 

[jc83ph]

Pass - there should be some response - but being blank.

Since for me the example Test address in my previously posted and you have seen worked. An I have checked on two different a machines one running Win 8.1, Excel 2007 and the other Win 10 , Excel 365 .

I conclude that there is something in either your User Profile or your machine system. - only suggestion is for you to check this on a different machine .

Good luck

Hi

Already work in 2016 office. see below

but in the sharepoint still not showing na pictures. see below

 

[jc83ph]

Hi BRNXX19,

One more help please. I try to saved the pictures in adobe icloud is work but the issue no showing picture only result " the picture can't be displayed" see below.

here the code i use:

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://alibinali0.sharepoint.com/sites/Lux-Qtr/SC/ABA%20Stock%20Pictures/"
  ' test
  'Const filepath As String = "https://upload.wikimedia.org/wikipedia/en/4/43/"
 
  Const filepath As String = "https://shared-assets.adobe.com/link/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

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