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

VBAでウェブ画像検索し、その画像をエクセルに貼り付けるという操作を作成しております。
（操作手順）※標準モジュールで作成
1.googleでA列にあるワードを画像検索
2.各列の画像１つをフォルダに保存
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, "&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 & "\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

すいません、緊急でよろしくお願いいたします。

Tak1wa

2015/04/19 03:36

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

ttt1212

2015/04/19 03:41

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

行動規範の内容に同意します

回答3件

自己解決

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

投稿2015/04/19 06:59

ttt1212

総合スコア16

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

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

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

投稿2015/04/19 03:48

Tak1wa

総合スコア4791

ttt1212

2015/04/19 03:52

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

Tak1wa

2015/04/19 04:07

DownloadFileToTempDirメソッドでCase Elseの記載がありますが、これはどのSelectに対する記載でしょう。不要な気がしますので消して良いと思います。デスクトップにブックを作成しているんですか？ということはActiveWorkbook.Pathはデスクトップを指しているのでしょうか。

ttt1212

2015/04/19 04:11

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

Tak1wa

2015/04/19 04:31

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

ttt1212

2015/04/19 04:40

まだファイル保存できておりません。１．そもそもそのURLは画像ファイルを指していますか？＞.SaveToFile ActiveWorkbook.Path & "\picture\p1.png デスクトップにpictureというフォルダを作成。 p1.pngというのは、この名前で検索結果の画像を保存して。という意味で書いております。 ※ActiveWorkbook.Path＝デスクトップ２．ADODB.Stream.SaveToFileでエラーは特に発生していない？特に発生していないようです。実行時にいは何もエラー表示されません

Tak1wa

2015/04/19 05:09

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

Tak1wa

2015/04/19 05:29

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

ttt1212

2015/04/19 06:09

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

htsign

2015/04/19 06:41

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

行動規範の内容に同意します

こんにちは。

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

lang
1Private Sub AddPicture() 
2    Dim shape As shape 
3    Set shape = ActiveSheet.Shapes.AddPicture( _ 
4        Filename:=ActiveWorkbook.Path & "\workbook.xlsm", _ 
5        LinkToFile:=False, _ 
6        SaveWithDocument:=True, _ 
7        Left:=ActiveCell.Left + ActiveCell.Width, _ 
8        Top:=ActiveCell.Top, _ 
9        Width:=0, _ 
10        Height:=0) 
11    shape.ScaleHeight 1, msoTrue 
12    shape.ScaleWidth 1, msoTrue 
13    Set shape = Nothing 
14End Sub