VBA google画像検索 画像表示

解決済

回答 3

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 4,308

ttt1212

score 17

エクセルの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さんより回答いただき、下記のように編集いたしました。
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 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
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 3

checkベストアンサー

0

検索クエリの入ったセルを選択(複数選択可)した状態でMainプロシージャを実行すれば、選択済みのすべてのセルの右隣に、クエリで検索して見つかった1つ目の画像を貼り付けます。
'Option Explicitは宣言されていない変数を認めないようにするための特殊な宣言です。
'これがないといきなり新しい変数を作ることができるようになるため、手軽な反面ミスタイプに気づきにくくなります。
Option Explicit

'ここが起点になります。
Private Sub Main()
    Dim cell As Range
    'Selection とは選択範囲を表す特殊なオブジェクトです。
    'このオブジェクトはセルを選択していればRangeオブジェクトになるし、
    '画像を選択していればShapeオブジェクトになるなど、実行時まで型が判別できません。
    'For Each ~ Nextは範囲を持ったオブジェクト(配列や連想配列など)をすべて舐めるための構文です。
    'Excel VBAにおいてはRangeオブジェクトにも使えるため、このようにしています。
    For Each cell In Selection
        Call GoogleSearch(cell)
    Next
End Sub

'Google画像検索して貼り付けるまでの一連の流れを取りまとめるためのプロシージャです。
Private Sub GoogleSearch(ByRef cell As Range)
    Dim query As String
    'セルに含まれる値を取り出し、文字列型にします。数字や時刻であっても文字列になります。
    query = CStr(cell.Value2)
    
    Dim html As String
    '指定のURLにアクセスして、サーバから返ってくるHTMLをテキストで取得します。
    html = FetchHtml("https://www.google.co.jp/search?tbm=isch&q=" & query)
    
    Dim nextUrl As String
    'HTMLテキストを探索して、最初に見つかる画像URLを取り出します。
    nextUrl = FindFirstUrlFromGoogleImageSearch(html)
    
    '上で得た画像URLにアクセスし、ファイルをダウンロードして一時フォルダに保存します。
    DownloadFileToTempDir nextUrl
    
    '一時フォルダに保存された画像をシートに貼り付けます。
    AddPicture cell
End Sub

'変数[url]にアクセスしてHTMLをテキストで返します。
Private Function FetchHtml(ByVal url As String) As String
    'JavaScriptではXMLHttpRequestと呼ばれるオブジェクトです。
    Dim xhr As Object
    Set xhr = CreateObject("MSXML2.XMLHTTP")
    
    'GETリクエストを非同期で要求するよう接続をオープンします。
    xhr.Open "GET", url, True
    '要求を送信します。
    xhr.send
    
    'Do (While|Until) ~ Loopは与えられた条件が成り立っている間、あるいは成り立つまで繰り返します。
    Do Until xhr.readyState = 4
        'DoEventsはウィンドウメッセージを処理させる命令です。
        '待機中、画面が応答なしになるのを防ぐ、くらいに思っておけばいいでしょう。
        DoEvents
    Loop
    
    '応答結果を返り値に設定します。
    FetchHtml = xhr.responseText
    
    'オブジェクト解放
    Set xhr = Nothing
End Function

Private Sub DownloadFileToTempDir(ByVal url As String)
    'ref: http://www.ka-net.org/blog/?p=4855
    
    '定数宣言です。
    '定数とは、変数と違って一度定義したら変えられない特殊な変数のようなものです。
    Const adTypeBinary = 1
    Const adSaveCreateOverWrite = 2
    
    Dim xhr As Object
    Set xhr = CreateObject("MSXML2.XMLHTTP")
    
    xhr.Open "GET", url, True
    'HTTPヘッダを設定します。詳しくはネットワーク系の基礎を勉強してください。
    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
    
    'ADODB.Streamはデータストリームを汎用的に扱うためのAPI群を提供します。
    With CreateObject("ADODB.Stream")
        '保存するものは画像なので、扱うデータはバイナリであることを設定しています。
        'ファイルをメモ帳で開いて文字化けしていなかったら「テキスト」、それ以外はすべて「バイナリ」くらいの認識でいいです。
        .Type = adTypeBinary
        'ストリームをオープンします。
        .Open
        'ストリームにデータを書き込みます。中身はバイナリなので人間には読めません。
        .Write xhr.responseBody
        'ストリームの中身をファイルに出力します。
        .SaveToFile Environ("TEMP") & "\vbatemp", adSaveCreateOverWrite
        'ストリームを閉じます。
        .Close
    End With
    
    'オブジェクト解放
    Set xhr = Nothing
End Sub

'HTMLテキストから最初に見つかる画像URLを返します。
Private Function FindFirstUrlFromGoogleImageSearch(ByVal html As String) As String
    Dim partOfHtml As String
    'Long型は32bit長のビットで表せる整数です。VB.NETでのLong(こちらは64bit)とは別物です。
    Dim idx As Long
    
    'HTMLソースの何文字目に "imgurl=" という文字列が含まれるのかを idx に格納します。
    idx = InStr(html, "imgurl=")
    'idx + 7 番目から後の文字列を抽出します。
    partOfHtml = Mid(html, idx + 7)
    '抽出後の文字列の何番目に "&" という文字列が含まれるのかを idx に格納します。
    idx = InStr(partOfHtml, "&")
    
    '最初から idx - 1 番目までを抽出して、返り値に設定します。
    FindFirstUrlFromGoogleImageSearch = Left(partOfHtml, idx - 1)
End Function

'与えられたRange型(セル)の右隣に、あらかじめ保存された画像を貼り付けます。
Private Sub AddPicture(ByRef cell As Range)
    Dim shape As shape
    'ここの詳しいパラメータの機能は私もよくは知りません。
    Set shape = ActiveSheet.Shapes.AddPicture( _
        Filename:=Environ("TEMP") & "\vbatemp", _
        'Excelでの画像貼り付けには複数の方法があり、
        'ファイルへのリンクとするのかExcelファイル自体に画像を含ませるのかを選択できます。
        'ここではExcelファイルに埋め込んでいます。
        LinkToFile:=False, _
        SaveWithDocument:=True, _
        'シートのA1の左上隅を頂点として、右にどのくらいずらすのかを指定します。
        Left:=cell.Left + cell.width, _
        'シートのA1の左上隅を頂点として、下にどのくらいずらすのかを指定します。
        Top:=cell.Top, _
        '貼り付ける画像の縦幅、横幅を指定します。
        'ここでは両方とも 0 に指定していますが、下でさらに別の設定をしています。
        width:=0, _
        height:=0)
    
    '貼り付けられた画像の縦幅横幅を、画像そのものの大きさに一致するようにします。
    shape.ScaleHeight 1, msoTrue
    shape.ScaleWidth 1, msoTrue
    
    'オブジェクト解放
    Set shape = Nothing
End Sub

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2015/04/20 00:52

    本当にありがとうございます!感謝です。

    この後、画像のサイズ変更を行いたいので、

    どこで何をしているのか簡単に書いていただけると嬉しいです。

    本当に本当にありがとうございます>_<

    キャンセル

  • 2015/04/20 01:28

    コメントを付けました。これでもかというくらい付けました。
    これでも分からないことがあれば、あなたの勉強のためにもご自分で調べてみることをお勧めします。
    大体の場合は、例えばWith句の意味を知りたいのであれば、
    Googleで [excel vba with] を検索すれば知りたいことは分かるでしょう。

    キャンセル

  • 2015/04/20 10:23

    お返事遅れてすいません。
    無事実装でいました。本当にありがとうございました。
    自分ももっとプログラミング力つけるよう、精進していきます。
    ありがとうございました。感謝です。

    キャンセル

  • 2015/04/20 12:34

    お役に立てて光栄です。
    kukiさんのスキル向上を応援しています。

    キャンセル

0

前提条件として、ワークブックが既に保存されている必要があります。(ActiveWorkbook.Pathを参照するため)
実装はかなり投げやりです。サーバが401や403を返す場合などは想定していません。
Excel 2013で動作確認しました。
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)
    'ref: http://www.ka-net.org/blog/?p=4855
    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, "&amp;")
    
    FindFirstUrlFromGoogleImageSearch = Left(partOfHtml, idx - 1)
End Function

Private Sub AddPicture()
    'ref: http://www.moug.net/tech/exvba/0120020.html
    Dim shape As shape
    Set shape = ActiveSheet.Shapes.AddPicture( _
        Filename:=ActiveWorkbook.Path & "\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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2015/04/19 15:58

    あぁ、いえ。削除しろと申しているのではありません。
    あなたに悪意がないことも分かっているつもりですので、今後気を付けていただければそれで十分ですよ。

    一度動く状態まで持って行っていただいて、少しずつコードを書き換えるのは難しいですか?
    私のコードは一応画像が取得できてセルの右隣に表示できるところまで確認しています。
    一度動くことを確認して、その後保存場所を変えたり、そういったことはできませんか?

    キャンセル

  • 2015/04/19 16:09

    動く状態までもっていきたいのですが、Private Sub AddPicture()のエラーが出てしまい、先に進みません・・・
    ちなみに、Filename:=の部分に存在するフォルダを指定すると、フォルダ内の画像が表示されます。

    キャンセル

  • 2015/04/19 16:10

    見づらいですが、今一度、コードを記入いたします。
    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, "&amp;")

    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

    キャンセル

0

※コメント欄が長くなりすぎたため新たに回答させていただきます。

コードを拝見しました。
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)
ここでやはり「,」が抜けていますね。
お分かりになりますでしょうか。2行目は
  Filename:=Environ("TEMP") & "\vbatemp", _
とならなければならないはずです。
この文を1行で書いてみると分かるかと思います。
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)
と書くことと等価です。Filenameのところが如何に異質かハッキリするでしょう。
「,」は引数はここからここまでです、とパーサ(プログラムの構文を解析する仕組み)に伝える役割を持ちます。
これを抜くとやれ「引数の数が少ない」だの「引数の型が違います」だの言われることになりますので、慣れないうちは注意して書くことが肝要です。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2015/04/19 21:44

    最後のプロシージャに
    Dim cell As Range
    For Each cell In Selection
    GoogleSearch cell.Value2
    Next
    を追加すると、無限に1つ目のセル画像が表示されます。
    一つずつ下に移動したいです・・・

    キャンセル

  • 2015/04/20 00:42

    返事が遅れました。すみません。
    GoogleSearchプロシージャに渡す引数を変えるところから書いた方がいいかもしれません。
    新規に回答を立ててコード全文を載せます。

    キャンセル

  • 2015/04/20 00:47

    本当にありがとうございます!感謝です。
    この後、画像のサイズ変更も行いたいので、
    どこで何をしているのか簡単に書いていただけると嬉しいです。
    本当に本当にありがとうございます>_<

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 90.21%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる