質問編集履歴

2 構文間違え

ttt1212

ttt1212 score 17

2015/04/19 16:37  投稿

VBA google画像検索 画像表示
エクセルのVBAで文字列に対する画像が表示されるマクロを作成したいです。
やりたいこととして例えば、
A列に5つワードが書かれており、
そのワードをひとつずつgoogleで画像検索し、検索結果から画像1つを
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業務を自動化することができます。

1 現在のコードを記載

ttt1212

ttt1212 score 17

2015/04/19 16:33  投稿

VBA google画像検索 画像表示
エクセルのVBAで文字列に対する画像が表示されるマクロを作成したいです。
やりたいこととして例えば、
A列に5つワードが書かれており、
そのワードをひとつずつgoogleで画像検索し、検索結果から画像1つを
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業務を自動化することができます。

思考するエンジニアのためのQ&Aサイト「teratail」について詳しく知る