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,
 

bbrnx19

Board Regular
Joined
Oct 25, 2006
Messages
196
what was the result of , there might be security access issues similar to pic .
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
insert manually Picture1.jpg


try a test with an other site make
VBA Code:
 Const filepath As String = "https://upload.wikimedia.org/wikipedia/en/4/43/"
and add to sheet2 cell C2
Excel Formula:
Microsoft_SharePoint

if with this site and below changes, and its working then its a site/security/authentications issue



should be ,
VBA Code:
url = Replace(url, " ", "&20")
this is to replace any spaces " " with "%20" in the url
 
Last edited:

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

jc83ph

New Member
Joined
Oct 9, 2014
Messages
29
what was the result of , there might be security access issues similar to pic .

View attachment 54726

try a test with an other site make
VBA Code:
 Const filepath As String = "https://upload.wikimedia.org/wikipedia/en/4/43/"
and add to sheet2 cell C2
Excel Formula:
Microsoft_SharePoint

if with this site and below changes, and its working then its a site/security/authentications issue




should be ,
VBA Code:
url = Replace(url, " ", "&20")
this is to replace any spaces " " with "%20" in the url
hi BBRNX19,

I try to copy and paste your code but still error.

this part how to add this in the formula? because the range is c2

"and add to sheet2 cell C2
Excel Formula:
Microsoft_SharePoint
"

Please can you guide me with the full code so that i will copy and paste and test run if the code is work.

Thanks for you help.
 

bbrnx19

Board Regular
Joined
Oct 25, 2006
Messages
196
pic.xlsm
ABC
1
2Microsoft_SharePoint
3
Sheet2


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/"
  ' 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 & ".png") <> False Then img = filepath & c.Value & ".png"
        
        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

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
 

jc83ph

New Member
Joined
Oct 9, 2014
Messages
29
pic.xlsm
ABC
1
2Microsoft_SharePoint
3
Sheet2


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/"
  ' 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 & ".png") <> False Then img = filepath & c.Value & ".png"
       
        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

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
Hi BBRNX19,

no picture "microsoft_sharepoint" after I add in c2 and no error.

and also I add this %20 in this part url = Replace(url, " ", "&20") - url = Replace(url, "%20", "&20") but same no photo showing.
 

jc83ph

New Member
Joined
Oct 9, 2014
Messages
29

ADVERTISEMENT

Hi BBRNX19,

I try again to use site of sharepoint only appear the error.
 

Attachments

  • Capture.PNG
    Capture.PNG
    153.9 KB · Views: 5

bbrnx19

Board Regular
Joined
Oct 25, 2006
Messages
196

ADVERTISEMENT

I have check code on two different machines using 2007 and 365 32-bit and code works fine as posted in post #13

have your tried this in a new blank workbook
 

jc83ph

New Member
Joined
Oct 9, 2014
Messages
29
I have check code on two different machines using 2007 and 365 32-bit and code works fine as posted in post #13

have your tried this in a new blank workbook
yes same no picture display. this code I add in sheet 2

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 = "http://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 & ".png") <> False Then img = filepath & c.Value & ".png"
        
        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

and this code I add 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
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,151,957
Messages
5,767,312
Members
425,404
Latest member
Bairkus

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