質問をすることでしか得られない、回答やアドバイスがある。

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

ただいまの
回答率

90.48%

  • VBA

    1858questions

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

【緊急】VBA ウェブ画像の表示「このイメージは現在表示できません」と出てしまう

解決済

回答 3

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 3,600

ttt1212

score 13

VBAでウェブ画像検索し、その画像をエクセルに貼り付けるという操作を作成しております。
(操作手順)※標準モジュールで作成
1.googleでA列にあるワードを画像検索
2.各列の画像1つをフォルダに保存
3.ファルダ内の画像を参照して、A列のワードの右に画像を表示

以下のようにプログラムしているのですが、エクセルでの画像表示が、
「このイメージは現在表示できません」となってしまいます。
原因としては、一時ディレクトリ(フォルダ)に保存されないことかと思います。
対処法を教えていただけないでしょうか。
よろしくお願いいたします。

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 & "\picture\p1.png"※保存したいファルダとファイル名を指定, 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()
    'ref: http://www.moug.net/tech/exvba/0120020.html
    Dim shape As shape
    Set shape = ActiveSheet.Shapes.AddPicture( _
        Filename:=ActiveWorkbook.Path & "\picture\p1.png※表示したい画像ファイルを指定", _
        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ページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

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

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

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

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

    詳細な説明はこちら

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

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

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

質問への追記・修正、ベストアンサー選択の依頼

  • Tak1wa

    2015/04/19 12:36

    これは、一時ディレクトリに画像が保存されるところまでは出来ているんですか? 「個人的には、保存先や参照先のファイルの設定が間違っているのかなと思います。 」この根拠を教えてください。

    キャンセル

  • ttt1212

    2015/04/19 12:41

    一時ディレクトリに画像が保存されるところまでは出来ていません。 ファイルの指定が間違っているので画像の保存ができないのだと思いました。

    キャンセル

回答 3

check解決した方法

0

同じ内容のトピックを前にも記載してしまっていたため、
こちらのトピックは一旦閉じさせていただきます。
移動先よりお願いいたします。
申し訳ございませんでした。
移動トピック

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

0

こんにちは。

以下は画像をシートにロードする部分について

Private Sub AddPicture() 
    Dim shape As shape 
    Set shape = ActiveSheet.Shapes.AddPicture( _ 
        Filename:=ActiveWorkbook.Path & "\workbook.xlsm", _ 
        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 

AddPictureメソッドの第一引数はAddする画像ファイル名を指定するべきだと思いますが、
なぜワークブックを?

投稿

編集

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2015/04/19 12:45

    画像ファイル名を指定したのですが、そもそも保存先のファルダに保存できていないので、画像ファイル名を書いても表示されませんでした。
    なので、思考錯誤してワークブック名を書いておりました・・・
    検索した画像が自分のフォルダに保存するには、どう書いたらよいのでしょう・・

    キャンセル

0

以下は保存部分について。

SaveToFileプロパティのパスがスラッシュになっているのでバックスラッシュに変えてみましょう。

Private Sub DownloadFileToTempDir(ByVal url As String) 
    '---省略
    With CreateObject("ADODB.Stream") 
        .Type = adTypeBinary 
        .Open 
        .Write xhr.responseBody 
        .SaveToFile ActiveWorkbook.Path & "/workbook"※保存したいファルダを指定, adSaveCreateOverWrite 
        .Close 
    End With 
    '---省略        
End Sub 

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2015/04/19 12:52

    バックスラッシュに変えました!
    しかし、画像はフォルダに保存されません。
    フォルダは事前に指定先のデスクトップ直下に作成済みです。

    キャンセル

  • 2015/04/19 13:07

    DownloadFileToTempDirメソッドでCase Elseの記載がありますが、これはどのSelectに対する記載でしょう。不要な気がしますので消して良いと思います。

    デスクトップにブックを作成しているんですか?ということはActiveWorkbook.Pathはデスクトップを指しているのでしょうか。

    キャンセル

  • 2015/04/19 13:11

    デスクトップにブック作成しています。
    ActiveWorkbook.Pathはデスクトップをさしています。
    ※Case Elseの部分を消しました。

    キャンセル

  • 2015/04/19 13:31

    未だにファイル保存まで出来ていないということでしょうか。
    1.そもそもそのURLは画像ファイルを指していますか?
    2.ADODB.Stream.SaveToFileでエラーは特に発生していない?

    キャンセル

  • 2015/04/19 13:40

    まだファイル保存できておりません。
    1.そもそもそのURLは画像ファイルを指していますか?
    >.SaveToFile ActiveWorkbook.Path & "\picture\p1.png
    デスクトップにpictureというフォルダを作成。
    p1.pngというのは、この名前で検索結果の画像を保存して。という意味で書いております。
    ※ActiveWorkbook.Path=デスクトップ

    2.ADODB.Stream.SaveToFileでエラーは特に発生していない?
    特に発生していないようです。
    実行時にいは何もエラー表示されません

    キャンセル

  • 2015/04/19 14:09

    手元にExcelが無いのが残念ですが…。
    1.DownloadFileToTempDirメソッドの引数で渡されるURLはそもそも期待したものでしょうか。
    2.デバッグ実行した時にSaveToFileまで処理は動いていますか。

    キャンセル

  • 2015/04/19 14:29

    あとは全然関係ないところを一応指摘しておきます。
    ・行頭のOption Explicit- の「-」を消す
    ・「"※保存したいファルダとファイル名を指定」と「※表示したい画像ファイルを指定」はソース上は実際には存在しませんよね?存在するのであれば消しておいてください。

    キャンセル

  • 2015/04/19 15:09

    1.DownloadFileToTempDirメソッドの引数で渡されるURLはそもそも期待したものでしょうか。
    >(ByVal url As String) こちらのことでしょうか。
    間違っているのでしょうか・・・。すいません、わかりません。
    ちなみにこちらのサイトを参考にしております。
    http://www.ka-net.org/blog/?p=4855
    2.デバッグ実行した時にSaveToFileまで処理は動いていますか。
    >動いているようです。
    Private Sub AddPicture()でエラーになります。

    不要な記載はすべて消しました!

    キャンセル

  • 2015/04/19 15:41

    先の質問でコード全文を載せたものです。
    (ByVal url As String) のurlに渡る文字列は、画像への直リンクを表すURLが入ってくることを期待してコーディングしています。
    ですので、デバッグ実行時にそのURLをコピーしてブラウザで読み込んでみて画像が表示されなければ、渡される文字列は間違っていることになります。

    キャンセル

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

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

関連した質問

同じタグがついた質問を見る

  • VBA

    1858questions

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