link pictures from Sharepoint to Excel macro

jc83ph

New Member
Joined
Oct 9, 2014
Messages
29
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

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

bbrnx19

Board Regular
Joined
Oct 25, 2006
Messages
195
If your just draging the photos from web site into excel using 'desktop app' and not using 'excel for the web',
as for the later my understanding VBA macros do not work.

Your FilePath use a space https;:// "li0.sharepoint.com/sites/Lux-Qtr/SC/Stock Pictures/"
but for URL spaces are replaced with %20 ie https;:// "li0.sharepoint.com/sites/Lux-Qtr/SC/Stock%20Pictures/"
 

jc83ph

New Member
Joined
Oct 9, 2014
Messages
29
hi bbrnx19,

Thank you for your reply.

I'm using the excel file not excel on the web. also, I try this HTTP:// "li0.sharepoint.com/sites/Lux-Qtr/SC/Stock%20Pictures/" but still is not working.
 

jc83ph

New Member
Joined
Oct 9, 2014
Messages
29
Hi Bbrnx19,

here the result the error
 

Attachments

  • Screen Shot 2022-01-07 at 3.14.15 PM.JPG
    Screen Shot 2022-01-07 at 3.14.15 PM.JPG
    102.6 KB · Views: 6

bbrnx19

Board Regular
Joined
Oct 25, 2006
Messages
195

ADVERTISEMENT

Yip Dir() will not work with URL, no out off the box URLCheck
insert into VBA in module
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
      .Open "GET", url, False
      .Send
      rc = .StatusText
    End With
    Set Request = Nothing
    If rc = "OK" Then URLCheck = True

    Exit Function
EndNow:
End Function
usage
VBA Code:
        If URLCheck(filepath & "NOPHOTO.jpg") <> False Then img = filepath & "NOPHOTO.jpg"
        If URLCheck(filepath & c.Value & ".jpg") <> False Then img = filepath & c.Value & ".jpg"

Have you also check if you can manually insert a picture from the sharepoint using the URL li0.sharepoint.com/sites/Lux-Qtr/SC/Stock%20Pictures/NOPHOTO.jpg to see if there is any security or additional popup prompts
 

jc83ph

New Member
Joined
Oct 9, 2014
Messages
29
Yip Dir() will not work with URL, no out off the box URLCheck
insert into VBA in module
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
      .Open "GET", url, False
      .Send
      rc = .StatusText
    End With
    Set Request = Nothing
    If rc = "OK" Then URLCheck = True

    Exit Function
EndNow:
End Function
usage
VBA Code:
        If URLCheck(filepath & "NOPHOTO.jpg") <> False Then img = filepath & "NOPHOTO.jpg"
        If URLCheck(filepath & c.Value & ".jpg") <> False Then img = filepath & c.Value & ".jpg"

Have you also check if you can manually insert a picture from the sharepoint using the URL li0.sharepoint.com/sites/Lux-Qtr/SC/Stock%20Pictures/NOPHOTO.jpg to see if there is any security or additional popup prompts
Hi bbrnx19,

Thanks for your reply.

Please check this I add the code as per you reply above.

in Sheet2:
Rich (BB 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 = "http://alibinali0.sharepoint.com/sites/Lux-Qtr/SC/ABA%20Stock%20Pictures/"
 
  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"
        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


Modules:
Rich (BB code):
Function URLCheck(url As String) As Boolean
    Dim Request As Object
    Dim ff As Integer
    Dim rc As Variant
     url = Replace(url, "http://alibinali0.sharepoint.com/sites/Lux-Qtr/SC/ABA%20Stock%20Pictures/ ", "&20")
    On Error GoTo EndNow
    Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")

    With Request
      .Open "GET", url, False
      .Send
      rc = .StatusText
    End With
    Set Request = Nothing
    If rc = "OK" Then URLCheck = True

    Exit Function
EndNow:
End Function
 

Attachments

  • Screen Shot 2022-01-07 at 8.23.22 PM.JPG
    Screen Shot 2022-01-07 at 8.23.22 PM.JPG
    65.3 KB · Views: 3
  • Screen Shot 2022-01-07 at 8.23.27 PM.JPG
    Screen Shot 2022-01-07 at 8.23.27 PM.JPG
    42.6 KB · Views: 3
  • Screen Shot 2022-01-07 at 8.20.21 PM.JPG
    Screen Shot 2022-01-07 at 8.20.21 PM.JPG
    203.5 KB · Views: 3

JEC

Well-known Member
Joined
Aug 21, 2021
Messages
777
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

You need to sync the sharepointfolder to your explorer, then Dir will work. Or you could use the filesystemobject
 

JEC

Well-known Member
Joined
Aug 21, 2021
Messages
777
Office Version
  1. 365
Platform
  1. Windows
There are lots of examples at this forum, have you already synced the folder to your explorer?
 
Learn Excel from Bill Jelen

Understanding data is crucial, and the easiest place to start is with Microsoft Excel.

Forum statistics

Threads
1,151,468
Messages
5,764,502
Members
425,219
Latest member
datdanigg

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
Top