• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Get images from the URL's in excel

R

Ramesh Deo

Member
Dear Ninjas,

Attached file is a sample. I have the URL's in Column "B" which are of images. I want help with a macro that can check the URL and fetch the images and paste into column "C"

Appriciate if any help me please as I have 100's to be gathered.

Thanks
 

Attachments

Ramesh Deo said:
Dear Ninjas,

Attached file is a sample. I have the URL's in Column "B" which are of images. I want help with a macro that can check the URL and fetch the images and paste into column "C"

Appriciate if any help me please as I have 100's to be gathered.

Thanks
Click to expand...
Hi,

Try the attached file and let me know if it works as intended...
Note that the code transfers the files to a temp. folder (you will be prompted to select one) and deletes them afterwards...

Hope this helps.
 

Attachments

Dear PCosta,

Thanks for your response. Its working but can we ignore to selecting folder. Actually I want if I update the URLs in that cells(B1 and B2) and the image should change accordingly. and can we fix the size of that images in a fix width and height.

Thanks
 
Hi !

Try this demonstration :​
Code: 
Private PxP, PyP

Private Declare Function GetDC& Lib "user32" (ByVal hWnd&)
Private Declare Function GetDeviceCaps& Lib "gdi32" (ByVal hdc&, ByVal nIndex&)

Function GetPPI(L&)
         GetPPI = 72 / GetDeviceCaps(GetDC(0&), L&)
End Function

Function ShapeInMiddle$(Rg As Range)
                   Dim Obj As Object
        If PxP = 0 Then PxP = GetPPI(88): PyP = GetPPI(90)
    With ActiveWindow
        Set Obj = .RangeFromPoint(.PointsToScreenPixelsX((Rg.Left + Rg.Width / 2) / PxP), .PointsToScreenPixelsY((Rg.Top + Rg.Height / 2) / PyP))
    End With
        If TypeName(Obj) <> "Range" Then ShapeInMiddle = Obj.Name
        Set Obj = Nothing
End Function

Sub Demo()
    With Cells(1).CurrentRegion.Columns
        If .Count < 3 Then Beep: Exit Sub
        VA = .Item(2).Value
    End With
    For R& = 2 To UBound(VA)
        If VA(R, 1) > "" And ShapeInMiddle(Cells(R, 3)) = "" Then
                 Cells(R, 3).Select
            With ActiveSheet.Shapes(ActiveSheet.Pictures.Insert(VA(R, 1)).Name)
                .Width = ActiveCell.Width
                 If .Height > ActiveCell.Height Then .Height = ActiveCell.Height
                .IncrementLeft (ActiveCell.Width - .Width) / 2
                .IncrementTop (ActiveCell.Height - .Height) / 2
            End With
        End If
    Next
End Sub
Do you like it ? So thanks to click on bottom right Like !
​
 
Try this out dude:
Code: 
Sub InsertPic()

Dim pic As String
Dim myPicture As Picture
Dim rng As Range
Dim cl As Range

Set rng = Range("C2:C4")  'Modify this range as needed. If image link URL in column B.

    For Each cl In rng
  
    pic = cl.Offset(0, -1)
  
    Set myPicture = Sheets(1).Pictures.Insert(pic)

        With myPicture
            .ShapeRange.LockAspectRatio = msoFalse
            .Width = cl.Width
            .Height = cl.Height
            .Top = Rows(cl.Row).Top
            .Left = Columns(cl.Column).Left
        End With
      
    Next
End Sub
 
Last edited:
Marc L said:
Hi !

Try this demonstration :​
Code: 
Private PxP, PyP

Private Declare Function GetDC& Lib "user32" (ByVal hWnd&)
Private Declare Function GetDeviceCaps& Lib "gdi32" (ByVal hdc&, ByVal nIndex&)

Function GetPPI(L&)
         GetPPI = 72 / GetDeviceCaps(GetDC(0&), L&)
End Function

Function ShapeInMiddle$(Rg As Range)
                   Dim Obj As Object
        If PxP = 0 Then PxP = GetPPI(88): PyP = GetPPI(90)
    With ActiveWindow
        Set Obj = .RangeFromPoint(.PointsToScreenPixelsX((Rg.Left + Rg.Width / 2) / PxP), .PointsToScreenPixelsY((Rg.Top + Rg.Height / 2) / PyP))
    End With
        If TypeName(Obj) <> "Range" Then ShapeInMiddle = Obj.Name
        Set Obj = Nothing
End Function

Sub Demo()
    With Cells(1).CurrentRegion.Columns
        If .Count < 3 Then Beep: Exit Sub
        VA = .Item(2).Value
    End With
    For R& = 2 To UBound(VA)
        If VA(R, 1) > "" And ShapeInMiddle(Cells(R, 3)) = "" Then
                 Cells(R, 3).Select
            With ActiveSheet.Shapes(ActiveSheet.Pictures.Insert(VA(R, 1)).Name)
                 If .Width > ActiveCell.Width - 4 Then .Width = ActiveCell.Width - 4
                 If .Height > ActiveCell.Height - 4 Then .Height = ActiveCell.Height - 4
                .IncrementLeft (ActiveCell.Width - .Width) / 2
                .IncrementTop (ActiveCell.Height - .Height) / 2
                .Placement = xlMoveAndSize
            End With
        End If
    Next
End Sub
Do you like it ? So thanks to click on bottom right Like !
​
Click to expand...


Thanks Mark. Its working as I expected.I liked it.
 
shahin said:
Try this out dude:
Code: 
Sub InsertPic()

Dim pic As String
Dim myPicture As Picture
Dim rng As Range
Dim cl As Range

Set rng = Range("C2:C4")  'Modify this range as needed. If image link URL in column B.

    For Each cl In rng
 
    pic = cl.Offset(0, -1)
 
    Set myPicture = Sheets(1).Pictures.Insert(pic)

        With myPicture
            .ShapeRange.LockAspectRatio = msoFalse
            .Width = cl.Width
            .Height = cl.Height
            .Top = Rows(cl.Row).Top
            .Left = Columns(cl.Column).Left
        End With
     
    Next
End Sub
Click to expand...

Thanks for your response but its getting error.
 
Ramesh Deo said:
Thanks for your response but its getting error.
Click to expand...
No error on my side with shahin's code …
… but if run twice, twice pictures on worksheet !
If you select a picture and delete it, whow another picture under ‼
People getting fat with this code also !

My code checks if a picture already exists within cell
before to add any picture and people stay fit …

The more pictures, the bigger workbook !

Save it as .xlsb (binary format) …
​
 

I slightly mod Demo procedure within post #4 …

You can also compress pictures via the Picture Tools menu.​
 
Dear Marc L, I suppose, it is flawless now.

Code: 
Sub InsertPic()

Dim pics As String
Dim myPics As Shape
Dim PicExists As Boolean
Dim myPic As Picture
Dim rng As Range
Dim cel As Range

Set rng = Range("C2", Range("B2").End(xlDown).Offset(0, 1))

    For Each cel In rng
        PicExists = False
        pics = cel.Offset(0, -1)

        For Each myPics In ActiveSheet.Shapes
            If myPics.TopLeftCell.Row = cel.Row Then
                PicExists = True
                Exit For
            End If
        Next myPics

        If Not PicExists Then
            Set myPic = ActiveSheet.Pictures.Insert(pics)
            With myPic
                .ShapeRange.LockAspectRatio = msoFalse
                .Width = cel.Width
                .Height = cel.Height
                .Top = Rows(cel.Row).Top
                .Left = Columns(cel.Column).Left
            End With
        End If
    Next cel

End Sub

Edit: Links are in B column and pictures to get settled in C column.
 
You must log in or register to reply here.
Back
Top