画像をDLするコードが動かない

質問

こんにちは。
秀和システムのVBAでIEを操作する書籍で解説されている、WEBサイトから画像データをDLするというコードが動かず困っています。
コードは以下です。
Range("Sheet1!$b$1")　に、秀和システムの公式サイトのURLが記載されています。

-----ここから-----

Dim obIE As Object '変数の定義を行います
Dim Obj As Object '変数の定義を行います

Dim Rtn_Down As Integer '変数の定義を行います
Dim Rtn_del As Integer '変数の定義を行います

'「Sleep」コマンドを使う場合の決まり文句
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'「URLDownloadToFile」を使う場合の決まり文句
Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long

'「DeleteUrlCacheEntry」を使う場合の決まり文句
Declare Function DeleteUrlCacheEntry Lib "wininet" _
Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

Sub ファイルをダウンロード()

Set obIE = CreateObject("InternetExplorer.Application") '変数の定義を行います
obIE.Visible = True '決まり文句。IEを見えるようにします
Range("Sheet1!$b$1").Hyperlinks(1).Follow NewWindow:=True '画像を取得したいページを新しいウィンドウで開きます

Sleep (2000)

' Do While obIE.ReadyState <> 4 '決まり文句。サイトが開くまで待ちます
Do While obIE.Busy = True '決まり文句。サイトが開いてなければ、繰り返し待ちます

Loop
' Loop

For Each Obj In obIE.document.images '表示されているサイトのイメージタグを一つずつ、変数objにセット

Rtn_del = DeleteUrlCacheEntry(Obj.href) 'ダウンロード対象のキャッシュをクリアします

Rtn_Down = URLDownloadToFile(0, Obj.href, "c:\test\" + Obj.Nameprop, 0, 0)
'ファイルをCドライブのtestというフォルダにダウンロード
Next '次のタグを処理します

End Sub

-----ここまで-----

F8でステップ実行すると、

Do While obIE.ReadyState <> 4 '決まり文句。サイトが開くまで
待ちます
Do While obIE.Busy = True '決まり文句。サイトが開いてな
ければ、繰り返し待ちます

Loop
Loop

のところでずっとループをくり返している、というところまでは突き止めましたが、どうやって解決したら良いか判らずにいます。

また、
ためしに、

Do While obIE.ReadyState <> 4 '決まり文句。サイトが開くまで
待ちます

をコメントアウトしたところ、先に進みましたが、

For Each Obj In obIE.document.images '表示されてい
るサイトのイメージタグを一つずつ、変数objにセット

のところで、

「実行時エラー '-2147467259(80004005)':
'Document'メソッドは失敗しました: 'IWebBrouser2'オブジェクト

というエラーが発生しました。

どなたかアドバイスの程、なにとぞお願い致します。

（なお、自分で入力したコードがダメだったあと、公式サイトからサンプルコードをDLして試しましたが、結果は同じでした）

回答No.2

real beatin（@realbeatin） · ベストアンサー

こんにちは。

書籍は読んでいませんけれど、
此処でご提示の記述は、ちょっとおかしいですね。
私の環境でも、同じ状態になります。
.Hyperlinks(1)　を　NewWindow　で　.Follow　する
ということなら、それは、obIEとは無関係ですし、
obIE　は　何も操作していない状態ですから、
何もない空っぽのページを　処理しようもないです。

一般論として、方法はだいたい２通りあります。
　●.Hyperlinks(1).Follow　した結果として開かれる
　　　新しいIEオブジェクトを捉え直す。
　●.Hyperlinks(1).Follow　の代りに　URLを指定して　
　　　URLを指定して　obIE.navigate　する
後者の例でお答えします。
修正箇所を★印で示します。
以下の修正を加えてから実行する限りでは、正常にダウンロードできること
を、確認しました。

Sub ファイルをダウンロード()

　　Set obIE = CreateObject("InternetExplorer.Application") '変数の定義を行います
　　obIE.Visible = True '決まり文句。IEを見えるようにします
'　　Range("Sheet1!$b$1").Hyperlinks(1).Follow NewWindow:=True '画像を取得したいページを新しいウィンドウで開きます　'　★トル
　　obIE.navigate Sheets("Sheet1").Range("B1").Hyperlinks(1).Address　'　★変更

'　　Sleep (2000)　'　★トル

　　' Do While obIE.ReadyState <> 4 '決まり文句。サイトが開くまで待ちます
　　Do While obIE.Busy = True '決まり文句。サイトが開いてなければ、繰り返し待ちます
　　　　Sleep (10)　'　★追加
　　Loop
　　' Loop

　　For Each Obj In obIE.document.images '表示されているサイトのイメージタグを一つずつ、変数objにセット

　　　　Rtn_del = DeleteUrlCacheEntry(Obj.href) 'ダウンロード対象のキャッシュをクリアします

　　　　Rtn_Down = URLDownloadToFile(0, Obj.href, "c:\test\" + Obj.Nameprop, 0, 0)
　　'ファイルをCドライブのtestというフォルダにダウンロード
　　Next '次のタグを処理します

End Sub

お礼

レスを頂きありがとうございます！
ご教示の方法で無事正常動作致しました。
やはりもとのソースがおかしかったのですね……。
初学者はこういう事態に立ち至るとデッドエンドなので、今回大変助かりました。
どうもありがとうございました！

回答No.1

noname#212067

>Do While obIE.ReadyState <> 4 '決まり文句。サイトが開くまで
>待ちます

>をコメントアウトしたところ、先に進みましたが、

先に進みますが、IEの処理が終わってない状態で次に行くので

「実行時エラー '-2147467259(80004005)':'Document'メソッドは失敗しました: :IWebBrouser2'オブジェクト

が発生してしまいます。

この部分は、本来ならIEが、ホームページの読込みを、完全に終わったあと
obIE.ReadyStateが4になって抜けるはずなのですが、機能しないようです

IEのバージョン等の問題かと思うのですが

Do Until obIE.StatusText Like "*ページが表示されました*"

Do Until obIE.Busy = False

なんかで、置き換えてみてください

お礼

レスを頂きありがとうございます！

>Do Until obIE.StatusText Like "*ページが表示されました*"

>Do Until obIE.Busy = False

>なんかで、置き換えてみてください

Do While obIE.ReadyState <> 4 '決まり文句。サイトが開くまで待ちます
Do While obIE.Busy = True '決まり文句。サイトが開いてなければ、繰り返し待ちます

をそれぞれ置き換えてみましたが、

Do Until obIE.StatusText Like "*ページが表示されました*"

の行で、「実行時エラー '-2147467259(80004005)':'Document'メソッドは失敗しました: :IWebBrouser2'オブジェクト……」が発生してしまいました……。