Thursday, January 21, 2016

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


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 = "" & 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



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



Set IE = Nothing

    End With


MsgBox "Done!!"

End Sub


No comments:

Post a Comment