ExcelのVBAで ホームページのソースコード

vExcelのVBAで　ホームページのソースコード一部分をぬきたいのですが、わかるかたおしえてください。

http://onlinestore.barneys.co.jp/html/item/001/0 …

こちらのサイトのZOOMUPした時の画像のURLを取得したいのです。


A列には、URL　でB列にはその画像URLを自動で取得というかんじです。


わかるかた教えていただけないでしょうか。

No.1 回答者： web2525 回答日時： 2013/01/23 15:21

http://www.ken3.org/cgi-bin/group/vba_ie_link.asp
↑
このサイトのほぼ丸写しですが


Sub ie_Link_TEST()

'１．調査したいURLをInputBoxで受け取ります(かなり手抜き・・・)
Dim strURL As String '入力値を受け取る変数

'INPUTBOXでURLをもらう
strURL = InputBox("調査するURLは？", "URL入力", "http://www.ken3.org/backno/backno_vba_mokuji.htm …
If strURL = "" Then
MsgBox "調査したいURLを指定してください"
Exit Sub '途中で抜ける
End If

'２．IEを起動させ、目的のページを表示させます。

Dim objIE As Object 'ＩＥオブジェクト参照用

'IEを起動する
Set objIE = CreateObject("InternetExplorer.application") 'IEのオブジェクトを作る
objIE.Visible = True '見えるようにする(お約束)

'.Navigate で 指定したURLを開く
objIE.Navigate strURL

'表示完了を待つ
While objIE.ReadyState <> 4
While objIE.Busy = True
DoEvents '特に何もしないで.Busyの状態が変わるまで待つ
Wend
Wend

'３．目的のページからリンク先を取り出し、セルに書き出します。

Dim i As Integer '添え字 i番目などで使用
Dim yLINE As Integer '行カウンタ、Y行目

'html ドキュメント リンク オブジェクトからデータをセルへ転記(代入)する。
Workbooks.Add '新規ブックを追加 データ転送用に新規のブックを追加する
Range("A1") = "調査したURLは " & strURL & " です" 'A1にURLを記述(セット)
Range("D1") = "リンクの数は " & objIE.Document.Links.Length & "です" 'D1にリンクの数をセット

'Range("A2") = ".Href(リンク先)" 'A2～F2 ２行目に見出しをセットする
'Range("B2") = ".OuterText"
'Range("C2") = ".OuterHTML"
'Range("D2") = ".InnerText"
'Range("E2") = ".InnerHTML"
'Range("F2") = ".Target"
Columns("A:F").ColumnWidth = 22 '列幅を22に変更

yLINE = 3 'セット開始の行を代入する
For i = 0 To objIE.Document.Links.Length - 1
'データをセルへセットする 'を付けて文字列にする(セルにセットしたいので)
ret = InStr(objIE.Document.Links(i).Href,"jpg") 'リンク先
If ret <> 0 And IsNull(ret) = False Then
Cells(yLINE, "A") = "'" & objIE.Document.Links(i).Href 'リンク先
'Cells(yLINE, "B") = "'" & objIE.Document.Links(i).OuterText '自分を含む テキスト(Innerと変わりない？)
'Cells(yLINE, "C") = "'" & objIE.Document.Links(i).OuterHTML '自分を含む HTML
'Cells(yLINE, "D") = "'" & objIE.Document.Links(i).InnerText '内側のテキスト
'Cells(yLINE, "E") = "'" & objIE.Document.Links(i).InnerHTML '内側のHTML
'Cells(yLINE, "F") = "'" & objIE.Document.Links(i).Target '_Blank や 表示先フレームの名前など

yLINE = yLINE + 1 'セット位置(行)を＋1する
End If
Next i

'抜き出し作業が終わったので、通常.QuitでIEを終了させる が 今回は残す
'objIE.Quit
Set objIE = Nothing

MsgBox "処理終了、ブラウザの表示内容 と シートを確認してください"

End Sub

No.2 ベストアンサー 回答者： DOUGLAS_ 回答日時： 2013/01/26 01:18

http://detail.chiebukuro.yahoo.co.jp/qa/question …
の方に全く同じご質問が出ておりますが、別の方法で回答いたします。

Sub with_HttpRequest()
　　Dim objHTTP As Object
　　Dim i As Long
　　Dim myHtml As Variant
　　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　　With objHTTP
　　　　For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
　　　　　　.Open "GET", Range("A" & i).Value, False
　　　　　　.Send
　　　　　　If InStr(.responseText, "previewPath") > 0 Then
　　　　　　　　myHtml = Split(.responseText, "previewPath")(2)
　　　　　　　　Range("B1").Offset(i - 1).Value = _
　　　　　　　　　　"http://onlinestore.barneys.co.jp" & Split(myHtml, "'")(1)
　　　　　　Else
　　　　　　　　Range("B1").Offset(i - 1).Value = "無効なＵＲＬです"
　　　　　　End If
　　　　Next i
　　End With
　　Set objHTTP = Nothing
End Sub