link pictures from Sharepoint to Excel macro

J

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,
 
Sort by date Sort by votes
what was the result of , there might be security access issues similar to pic .
bbrnx19 said:
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
Click to expand...
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



jc83ph said:
url = Replace(url, "http://alibinali0.sharepoint.com/sites/Lux-Qtr/SC/ABA%20Stock%20Pictures/ ", "&20")
Click to expand...
should be ,
VBA Code: 
url = Replace(url, " ", "&20")
this is to replace any spaces " " with "%20" in the url
 
Last edited:
Upvote 0

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
bbrnx19 said:
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
Click to expand...
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.
 
Upvote 0
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
 
Upvote 0
bbrnx19 said:
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
Click to expand...
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.
 
Upvote 0
Hi BBRNX19,

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

Attachments

  • Capture.PNG
    Capture.PNG
    153.9 KB · Views: 20
Upvote 0
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
 
Upvote 0
bbrnx19 said:
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
Click to expand...
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Locked
  • Question Question
" this image cannot currently be displayed" from excel to adobe icloud
Replies
1
Views
2K
Fluff
Fluff
M
  • Question Question
Excel Macro to insert picture into excel from SharePoint or website !
Replies
0
Views
554
MAlhash
M
I
  • Question Question
Could you check my code please
Replies
5
Views
1K
JoeMo
J
R
  • Question Question
Creating linked pictures in powerpoint from excel ranges
Replies
4
Views
4K
Phoenixmoto
P
I
  • Question Question
Run time error 1004, Application defined or object defined error
2
Replies
10
Views
3K
ipbr21054
I

Forum statistics

Threads
1,223,214
Messages
6,170,775
Members
452,353
Latest member
strainu

Share this page

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