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,

 

[jc83ph]

this site is empty

 

[bbrnx19]

one last shot the filename is case sensitive Microsoft_SharePoint

 

[jc83ph]

one last shot the filename is case sensitive Microsoft_SharePoint

no showing because this site is empty:

 

[jc83ph]

Hi BBRNX19,

Good day.

I try again to run the code but here the result of error in yellow highlight

in module no error

Please help me to fix this code.


Regards,

 

[bbrnx19]

check the TLS 1.2 is tick on

add re try the test

 

[bbrnx19]

include some debugging to check connection response

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

 

[jc83ph]

check the TLS 1.2 is tick on

View attachment 54865

add re try the test

Hi, this already tick on in my computer.

 

[jc83ph]

include some debugging to check connection response

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

i add already this and no error appear. but still no picture showing. here the code i copy and paste from you.

Function URLCheck(url As String) As Boolean
    Dim Request As Object
    Dim ff As Integer
    Dim rc As Variant
     url = Replace(url, "%20", "&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

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/"
  
  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

 

[bbrnx19]

' look at immediate window CrtL+G

please paste contents here

 

[jc83ph]

please paste contents here

please paste contents here

Hi only this showing.