Thursday, January 21, 2016

Use excel to search image on google and insert link of first image found


Hi,

Making project where you need to download tens of hundreds of images from web & tired of googling around..Here comes the solution using Excel VBA Macro.

In column A insert name of objects to be download & in Column B you will get URL of Image & in Column C you will get Image of the same size of your cell.

Click to Download


Source Code:
'Requires additional references to Microsoft Internet Control

'Requires additional HTML object library

Public Function URLDecode(url$) As String
    With CreateObject("ScriptControl")
        .Language = "JavaScript"
        URLDecode = .Eval("unescape(""" & url & """)")
    End With
End Function

Public Sub Fetch_Image()

Dim IE As InternetExplorer

Dim HTMLdoc As HTMLDocument

Dim imgElements As IHTMLElementCollection

Dim imgElement As HTMLImg

Dim aElement As HTMLAnchorElement

Dim n As Integer, i As Integer

Dim url As String, url2 As String, furl as string

Dim m, lastRow As Long

  

lastRow = Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To lastRow

    url = "https://www.google.co.in/search?q=" & Cells(i, 1) & "&source=lnms&tbm=isch&sa=X&rnd=1"

    Set IE = New InternetExplorer

  
    With IE

    .Visible = False

    .navigate url

  
    Do Until .readyState = 4: DoEvents: Loop

    'Do Until IE.document.readyState = "complete": DoEvents: Loop

    Set HTMLdoc = .document

    Set imgElements = HTMLdoc.getElementsByTagName("IMG")

  
    n = 1

    For Each imgElement In imgElements

        If InStr(imgElement.src, sImageSearchString) Then

            If imgElement.ParentNode.nodeName = "A" Then

                Set aElement = imgElement.ParentNode

              

                If n = 2 Then

                url2 = aElement.href

                url3 = imgElement.src

                GoTo done:

                End If

                n = n + 1

                End If

        End If

    Next

done:

furl = InStrRev(url2, "&imgrefurl=", -1)

furl = Mid(url2, 40, furl - 40)

furl = URLDecode(furl)


    Cells(i, 2) = furl

    Set m = ActiveSheet.Pictures.Insert(furl)

    With Cells(i, 3)

    t = .Top

    l = .Left

    w = .Width

    h = .Height

    End With

    With m

    .Top = t

    .Left = l

    .ShapeRange.Width = w

    .ShapeRange.Height = h

    End With

  

IE.Quit

Set IE = Nothing

    End With

Next



MsgBox "Done!!"

End Sub



Cheers!!