Open urls from list and scrape only image in link

[Subbie]

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:

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]

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

 

[Anthony47]

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:

#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...

 

[Subbie]

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]

..my path in the code is "C:\Users\marti\Documents\Family Historian Projects\Connolly Family Tree\Connolly Family Tree.fh_data\Media"

 

[Anthony47]

Your path must be declared as

"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]

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

 

[Anthony47]