Open urls from list and scrape only image in link

Subbie

New Member
Joined
May 11, 2019
Messages
32
Hi
I am returning to the forum after a long absence. I no longer use excel regularly now I am retired.
I am researching genealogy and need to scrape a list of images (Plus 2000) I have listed them in a column (A) in excel and have tried a number of solutions from the web, the latest being:
VBA Code:
Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("A1:A3")
For Each cell In Rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
If .Width > xRg.Width Then .Width = xRg.Width * 2 / 3
If .Height > xRg.Height Then .Height = xRg.Height * 2 / 3
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
lab:
Set Pshp = Nothing
Range("A2").Select
Next
Application.ScreenUpdating = True
End Sub

This is the one that got me closest. However, all it does is insert a rectangle shape in column B but no image.
An example of the link I am using is Genealogy Image.

This forum has always been very helpful and I hope that someone might come to my rescue. Appreciate any help given.

Martin
 

Subbie

New Member
Joined
May 11, 2019
Messages
32
Yes Anthony. I want to have them in a folder on the hard disc, so that I can use them in a family tree software that I have.
Martin
 

Some videos you may like

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
2,135
For this I will reuse my Function GetWebFile, that rely on Function URLDownloadToFile (a Windows' API).
The new code, that replace the previous one is:
VBA Code:
#If VBA7 Then       '!!! ON  TOP  OF  THE  VBA  MODULE   !!!!
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, ByVal szURL As String, _
        ByVal szFileName As String, ByVal dwReserved As LongPtr, _
        ByVal lpfnCB As LongPtr) As Long
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
        ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub GetCoAPict()
'Dim IE As MSHTML, AColl As IHTMLElementCollection
Dim IE As Object, AColl As Object, I As Long, myItm As Object
Dim JJ As Long, FreeCol As String, myURL As String, BaseAdd As String
Dim myResp As Variant, LocalPath As String
'
FreeCol = "B"               '<<< A free Column to hold the picture names
LocalPath = "C:\PROVA\"     '<<< Directory to save images; final \
'
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
BaseAdd = "https://www.wikitree.com"
'
For JJ = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    myURL = Cells(JJ, "A")
    '        https://www.wikitree.com/photo.php/6/6e/Bigod-1.png
    With IE
        .navigate myURL
        Sleep 100
        Do While .Busy: DoEvents: Sleep (30): Loop  'Attesa not busy
        Do While .readyState <> 4: DoEvents: Sleep (30): Loop 'Attesa documento
    End With
    For I = 1 To 6          'Wait for image div
        Sleep 300
        Set AColl = IE.document.getElementsByClassName("nine")
        If AColl.Length = 1 Then Exit For
    Next I
    If I < 6 Then           'if not TimeOut:
        Set myItm = AColl(0).getElementsByTagName("img")(0)
        Cells(JJ, FreeCol).Value = BaseAdd & myItm.getAttribute("src")
        If Len(LocalPath) > 2 Then
            myResp = GetWebFile(Cells(JJ, FreeCol).Value, LocalPath)
        End If
    End If
Next JJ
IE.Quit
Set IE = Nothing
End Sub

Function GetWebFile(ByVal myURL, ByVal myPath As String) As Variant
'byAnthony, ritorna Image Path & name OPPURE 0 se fail
Dim PathNName As String, URL As String
Dim mySplit, Resp As Long
mySplit = Split(myURL, "/")
PathNName = myPath & mySplit(UBound(mySplit))
Resp = URLDownloadToFile(0, myURL, PathNName, 0, 0)
If Resp = 0 Then
    GetWebFile = PathNName
    Exit Function
Else
    GetWebFile = 0
End If
End Function

You need to declare wich is the LocalPath for downloaded images (see instruction marked <<<); if LocalPath is empty then only the names of the pictures will be extracted to the FreeCol

Try...
 
Solution

Subbie

New Member
Joined
May 11, 2019
Messages
32
Hi Anthony
The code ranm and brought all the links in to the sheet column C but did not load into file I set on hard disk. No error messages appeared.
Martin
 

Subbie

New Member
Joined
May 11, 2019
Messages
32
..my path in the code is "C:\Users\marti\Documents\Family Historian Projects\Connolly Family Tree\Connolly Family Tree.fh_data\Media"
 

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
2,135

ADVERTISEMENT

Your path must be declared as
Rich (BB code):
"C:\Users\marti\Documents\Family Historian Projects\Connolly Family Tree\Connolly Family Tree.fh_data\Media\"
Probably your picures are now in "C:\Users\marti\Documents\Family Historian Projects\Connolly Family Tree\Connolly Family Tree.fh_data"

Re-try..
 

Subbie

New Member
Joined
May 11, 2019
Messages
32
Brilliant Anthony...that's were they were.
The code has worked perfectly. Your effort is much appreciated and you have solved the issue. It has saved my old brain a lot of work.Thatnk you so much.
Martin
 

Watch MrExcel Video

Forum statistics

Threads
1,127,336
Messages
5,624,093
Members
416,011
Latest member
chengkoonwing

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