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

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)

jc83ph

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

did you see my attached for the result of ctrl+G?

Thanks you advance for your help. I hope you can fix this.
 

bbrnx19

Board Regular
Joined
Oct 25, 2006
Messages
196
Pass - there should be some response - but being blank.

Since for me the example Test address in my previously posted and you have seen worked. An I have checked on two different a machines one running Win 8.1, Excel 2007 and the other Win 10 , Excel 365 .

I conclude that there is something in either your User Profile or your machine system. - only suggestion is for you to check this on a different machine .

Good luck
 

jc83ph

New Member
Joined
Oct 9, 2014
Messages
29
Pass - there should be some response - but being blank.

Since for me the example Test address in my previously posted and you have seen worked. An I have checked on two different a machines one running Win 8.1, Excel 2007 and the other Win 10 , Excel 365 .

I conclude that there is something in either your User Profile or your machine system. - only suggestion is for you to check this on a different machine .

Good luck
Hi

Already work in 2016 office. see below
1641837452636.png


but in the sharepoint still not showing na pictures. see below

1641837497631.png
 

jc83ph

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

One more help please. I try to saved the pictures in adobe icloud is work but the issue no showing picture only result " the picture can't be displayed" see below.
1641886303703.jpeg


here 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://alibinali0.sharepoint.com/sites/Lux-Qtr/SC/ABA%20Stock%20Pictures/"
  ' test
  'Const filepath As String = "https://upload.wikimedia.org/wikipedia/en/4/43/"
 
  Const filepath As String = "https://shared-assets.adobe.com/link/a035cb43-3ac8-4127-5e23-83e0614f81bd/"
 
  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

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
 
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,152,235
Messages
5,768,951
Members
425,507
Latest member
AndreaWorkPlace

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