質問編集履歴

2 構文間違え

ttt1212 score 17

2015/04/19 16:37  投稿

VBA　google画像検索　画像表示

エクセルのVBAで文字列に対する画像が表示されるマクロを作成したいです。

やりたいこととして例えば、

A列に５つワードが書かれており、

そのワードをひとつずつgoogleで画像検索し、検索結果から画像１つを

A列の文字列の横に表示する。ということです。

ブラウザを開いてワード検索するところまで書いたのですが、それ以降の処理がわかりません。

教えていただきたいです、よろしくお願いいたします。

Private Sub GoogleSearch()

Dim objIE As Object

Set objIE = CreateObject(“InternetExplorer.Application”)

objIE.Visible = True

objIE.navigate “http://www.google.co.jp/”

Sleep (1500)

Call IeWait(objIE)

objIE.document.forms(0).Item(“q”).Value = “チョコレート”

Sleep (1000)

objIE.document.getElementById(“gbqfb”).Click

‘objIE.Quit

‘Set objIE = Nothing

End Sub

ーーーーーーーー

整理のため、今一度コードを現在のコードを記載します。

※htsignさんより回答いただき、下記のように編集いたしました。

```lang-VBAスプリクト

Option Explicit

Private Sub Main()

Call GoogleSearch(ActiveCell.Value2)

End Sub

Private Sub GoogleSearch(ByVal query As String)

Dim html As String

html = FetchHtml("https://www.google.co.jp/search?tbm=isch&q=" & query)

Dim nextUrl As String

nextUrl = FindFirstUrlFromGoogleImageSearch(html)

DownloadFileToTempDir nextUrl

AddPicture

End Sub

Private Function FetchHtml(ByVal url As String) As String

Dim xhr As Object

Set xhr = CreateObject("MSXML2.XMLHTTP")

xhr.Open "GET", url, True

xhr.send

Do Until xhr.readyState = 4

DoEvents

Loop

FetchHtml = xhr.responseText

Set xhr = Nothing

End Function

Private Sub DownloadFileToTempDir(ByVal url As String)

Const adTypeBinary = 1

Const adSaveCreateOverWrite = 2

Dim xhr As Object

Set xhr = CreateObject("MSXML2.XMLHTTP")

xhr.Open "GET", url, True

xhr.setRequestHeader "Pragma", "no-cache"

xhr.setRequestHeader "Cache-Control", "no-cache"

xhr.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"

xhr.send

Do Until xhr.readyState = 4

DoEvents

Loop

With CreateObject("ADODB.Stream")

.Type = adTypeBinary

.Open

.Write xhr.responseBody

.SaveToFile ActiveWorkbook.Path & "vbatemp", adSaveCreateOverWrite

.SaveToFile Environ("TEMP") & "vbatemp", adSaveCreateOverWrite

.Close

End With

End Sub

Private Function FindFirstUrlFromGoogleImageSearch(ByVal html As String) As String

Dim partOfHtml As String

Dim idx As Long

idx = InStr(html, "imgurl=")

partOfHtml = Mid(html, idx + 7)

idx = InStr(partOfHtml, "&")

FindFirstUrlFromGoogleImageSearch = Left(partOfHtml, idx - 1)

End Function

Private Sub AddPicture()

Dim shape As shape

Set shape = ActiveSheet.Shapes.AddPicture( _

Filename:=Environ("TEMP") & "vbatemp", _

LinkToFile:=False, _

SaveWithDocument:=True, _

Left:=ActiveCell.Left + ActiveCell.Width, _

Top:=ActiveCell.Top, _

Width:=0, _

Height:=0)

shape.ScaleHeight 1, msoTrue

shape.ScaleWidth 1, msoTrue

Set shape = Nothing

End Sub

```

VBA 2709 questions VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。 Myタグに追加

1 現在のコードを記載

ttt1212 score 17

2015/04/19 16:33  投稿

VBA　google画像検索　画像表示

エクセルのVBAで文字列に対する画像が表示されるマクロを作成したいです。

やりたいこととして例えば、

A列に５つワードが書かれており、

そのワードをひとつずつgoogleで画像検索し、検索結果から画像１つを

A列の文字列の横に表示する。ということです。

ブラウザを開いてワード検索するところまで書いたのですが、それ以降の処理がわかりません。

教えていただきたいです、よろしくお願いいたします。

Private Sub GoogleSearch()

Dim objIE As Object

Set objIE = CreateObject(“InternetExplorer.Application”)

objIE.Visible = True

objIE.navigate “http://www.google.co.jp/”

Sleep (1500)

Call IeWait(objIE)

objIE.document.forms(0).Item(“q”).Value = “チョコレート”

Sleep (1000)

objIE.document.getElementById(“gbqfb”).Click

‘objIE.Quit

‘Set objIE = Nothing

End Sub

End Sub

ーーーーーーーー

整理のため、今一度コードを現在のコードを記載します。

※htsignさんより回答いただき、下記のように編集いたしました。

```lang-VBAスプリクト

Option Explicit

Private Sub Main()

Call GoogleSearch(ActiveCell.Value2)

End Sub

Private Sub GoogleSearch(ByVal query As String)

Dim html As String

html = FetchHtml("https://www.google.co.jp/search?tbm=isch&q=" & query)

Dim nextUrl As String

nextUrl = FindFirstUrlFromGoogleImageSearch(html)

DownloadFileToTempDir nextUrl

AddPicture

End Sub

Private Function FetchHtml(ByVal url As String) As String

Dim xhr As Object

Set xhr = CreateObject("MSXML2.XMLHTTP")

xhr.Open "GET", url, True

xhr.send

Do Until xhr.readyState = 4

DoEvents

Loop

FetchHtml = xhr.responseText

Set xhr = Nothing

End Function

Private Sub DownloadFileToTempDir(ByVal url As String)

Const adTypeBinary = 1

Const adSaveCreateOverWrite = 2

Dim xhr As Object

Set xhr = CreateObject("MSXML2.XMLHTTP")

xhr.Open "GET", url, True

xhr.setRequestHeader "Pragma", "no-cache"

xhr.setRequestHeader "Cache-Control", "no-cache"

xhr.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"

xhr.send

Do Until xhr.readyState = 4

DoEvents

Loop

With CreateObject("ADODB.Stream")

.Type = adTypeBinary

.Open

.Write xhr.responseBody

.SaveToFile ActiveWorkbook.Path & "vbatemp", adSaveCreateOverWrite

.Close

End With

End Sub

Private Function FindFirstUrlFromGoogleImageSearch(ByVal html As String) As String

Dim partOfHtml As String

Dim idx As Long

idx = InStr(html, "imgurl=")

partOfHtml = Mid(html, idx + 7)

idx = InStr(partOfHtml, "&")

FindFirstUrlFromGoogleImageSearch = Left(partOfHtml, idx - 1)

End Function

Private Sub AddPicture()

Dim shape As shape

Set shape = ActiveSheet.Shapes.AddPicture( _

Filename:=Environ("TEMP") & "vbatemp", _

LinkToFile:=False, _

SaveWithDocument:=True, _

Left:=ActiveCell.Left + ActiveCell.Width, _

Top:=ActiveCell.Top, _

Width:=0, _

Height:=0)

shape.ScaleHeight 1, msoTrue

shape.ScaleWidth 1, msoTrue

Set shape = Nothing

End Sub

```

VBA 2709 questions VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。 Myタグに追加