EXCEL VBAでたくさんのURLの一覧からHTTPレスポンスコードを取得したい。

VBA初心者です。
EXCEL VBAでプログラミングの練習をしています。

シート名：一覧
URL記入セル：A1～A100
結果を記入するセル：B1～B100
があり、URL記入セルに入力されているURLにアクセスし
レスポンスコードを（404とか200とか）B列に書き出す
というのを実行できるコードの書き方を教えてください。
（1週間取り組んでいますがまだできません・・・）
サンプルコードを直接改定頂けると最高です。

宜しくお願いします。

No.1 ベストアンサー 回答者： kenpon24 回答日時： 2009/11/25 13:15

こんな感じでしょうかね。

たぶん。。。

Sub Sample()

　　Dim i As Long
　　Dim bottom As Long
　　
　　bottom = Range("A65536").End(xlUp).Row
　　
　　For i = 1 To bottom
　　　　
　　　　Range("B" & i) = GetWebStatus(Range("A" & i))
　　
　　Next i
　　
End Sub

Function GetWebStatus(URL As String) As String

　　Dim WinHttp As Object

　　Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")

On Error GoTo INVALID

　　WinHttp.Open "GET", URL, False
　　WinHttp.send

　　GetWebStatus = WinHttp.Status
　　
　　Set WinHttp = Nothing
　　
　　Exit Function
　　
INVALID:
　　GetWebStatus = "Invalid URL"
　　
　　Set WinHttp = Nothing
　　
　　
End Function

この回答へのお礼

＞kenpon24さん

ご回答有難うございます。
一番早く解決できたのでBAにさせていただきます。

まだ、レベルが低すぎてソースコードの細かい部分が
理解できていませんが、書いていただいたコードを基に
学習していきます。

有難うございました！

お礼日時：2009/11/25 15:09

No.2 回答者： Wendy02 回答日時： 2009/11/25 14:26

こんにちは

私はやったことがないですが、そういえば、Webサイトのあるなしを、Status で取得方法があるのだなって、言われて思い出しました。しかし、私が最初に考えたものは、#1さんとほぼイメージとしては同じなのですが、少し工夫をしてみました。

'-------------------------------------------

'Option Explicit
Dim objHTTP As Object 'モジュールの上部に置く
Sub CheckURL()
　　Dim ret As Variant
　　Dim c As Range
　　On Error GoTo ErrHandler
　　If objHTTP Is Nothing Then
　　　　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　　End If
　　
　　For Each c In Range("A1", Range("A2000").End(xlUp))
　　　　If StrConv(c.Value, vbLowerCase) Like "http://*" Then
　　　　　　c.Offset(, 1).Value = GetHttpHeader(c.Value)
　　　　End If
　　Next
ErrHandler:
　　If Err.Number > 0 Then
　　　MsgBox Err.Number & " : " & Err.Description
　　End If
　　Set objHTTP = Nothing
End Sub
Function GetHttpHeader(ByVal strURL As String)
Dim ret As Variant
　　ret = Empty
　　On Error Resume Next
　　objHTTP.Open "GET", strURL, False
　　objHTTP.Send
　　　ret = objHTTP.Status
　　On Error GoTo 0
　　If ret <> 0 Then
　　　GetHttpHeader = ret
　　End If
End Function

この回答へのお礼

＞fuyuhikoさん

ご回答有難うございます。
まだ、レベルが低くてすんなりと違いを認識できていませんが
問題なく、解決できました！

有難うございます。

お礼日時：2009/11/25 15:12