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

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
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/"
 
Upvote 0
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.
 
Upvote 0
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: 86
Upvote 0
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
 
Upvote 0
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: 24
  • 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: 23
  • 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: 25
Upvote 0
You need to sync the sharepointfolder to your explorer, then Dir will work. Or you could use the filesystemobject
 
Upvote 0
There are lots of examples at this forum, have you already synced the folder to your explorer?
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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