link pictures from Sharepoint to Excel macro

jc83ph

New Member
Joined
Oct 9, 2014
Messages
31
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:
ec77546a-baa2-42f5-8b9a-40fb2530a65e.jpg


Screen Shot 2022-01-07 at 10.33.59 AM.JPG

here is the code I use
VBA Code:
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,
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Hi BBRNX19,

Good day.

I try again to run the code but here the result of error in yellow highlight
Screen Shot 2022-01-10 at 10.08.24 AM.JPG


in module no error

Please help me to fix this code.


Regards,
 
Upvote 0
include some debugging to check connection response
VBA Code:
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
 
Upvote 0
include some debugging to check connection response
VBA Code:
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.
VBA Code:
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

VBA Code:
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
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,291
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top