グーグルに登録されているかをチェックする場合

質問

エクセルのE列にURLがあるとします。（数は500～1000ぐらい）

F列には、Ｅ列にあるURLをグーグルで検索し、検索結果がある場合は、「○」ない場合は「×」で判定します。

G列には、グーグルで検索結果の約○○件、あるいは○件、これら○に入る数字を取得したいです。

そこで、以前、同じことを教えてもらったのですが、グーグルの使用が変更になったせいかすべて検索結果が「×」判定となってしまいました。
そのコードが下記なのですが、どこを修正すればいいのか教えてください。

よろしくお願いします。

'標準モジュール
Private Const SKEY As String = "http://www.google.co.jp/search?hl=ja&q="
Public Sub GoogleCheckers()
Dim c As Range
Dim buf As String
Const qt As String = ""
With ThisWorkbook.Sheets("登録チェック")
For Each c In Range("E6", Cells(Rows.Count, 5).End(xlUp))
If c.Value <> "" Then
Application.ScreenUpdating = False
buf = UrlEncode(c.Value)
buf = SKEY & buf
ItemCehck buf, c
Application.ScreenUpdating = True
End If
Next
End With
End Sub

Private Sub ItemCehck(ByVal strURL As String, iRng As Range)
Dim rng As Range
Dim objHTTP As Object
Dim i As Long, j As Long
Dim c As Variant
Dim httpLog As String
Dim msgbuf As Variant
Dim LimitNum As Long
On Error GoTo ErrHandler
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")

objHTTP.Open "GET", strURL, False
objHTTP.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows; U; Windows NT 5.1; en-JA; rv:1.9.2.12)"

objHTTP.Send
If Err.Number = 0 Then
If objHTTP.Status = 200 Then
httpLog = objHTTP.ResponseText
Call ContentsCheck(httpLog, iRng)
ElseIf objHTTP.Status >= 400 Then
iRng.Offset(, 1).Value = "アクセスエラー"
End If
Else
iRng.Offset(, 1).Value = "?"
End If
Exit Sub
ErrHandler:
iRng.Offset(, 1).Value = "不明"
End Sub
Private Sub ContentsCheck(httpLog As String, rng As Range)
'rev:101226
Dim i As Long, j As Long
Dim buf As Variant
Const STXT As String = "検索オプション</a></div><div><div id=resultStats>"
i = InStr(1, httpLog, STXT, 1)
If i > 0 Then
buf = Mid(httpLog, i + Len(STXT), 50)
j = InStr(1, buf, "件<nobr>", 1)
buf = Mid(buf, 1, j)
buf = Replace(buf, "約", "")
buf = Replace(buf, "件", "")
End If
If CLng(Val(buf)) > 0 Then
rng.Offset(, 1).Value = "○"
rng.Offset(, 2).Value = buf
Else
rng.Offset(, 1).Value = "×"
End If
End Sub

Private Function UrlEncode(ByVal sText As String) As String
Dim buf As String
If Len(sText) = 0 Then Exit Function
With CreateObject("ScriptControl")
.Language = "JScript"
buf = .CodeObject.encodeURI(sText)
buf = Replace(buf, ":", "%3A", , , 1)
buf = Replace(buf, "/", "%2F", , , 1)
UrlEncode = buf
End With
End Function

回答No.1

ki-aaa · ベストアンサー

以前の回答者の返答が無いようですので。

Private Sub ContentsCheck(httpLog As String, rng As Range)
　Dim i As Long, j As Long
　Dim Buf As String
　i = InStr(1, httpLog, "検索オプション", 1)
　If i > 0 Then
　　Buf = Mid(httpLog, i, 400)
' Debug.Print Buf
　　j = InStr(1, Buf, "<div id=resultStats>", 1)
　　Buf = Mid(Buf, j + Len("<div id=resultStats>"))
' Debug.Print Buf
　　j = InStr(1, Buf, "件<nobr>", 1)
　　Buf = Mid(Buf, 1, j)
' Debug.Print Buf
　　Buf = Replace(Buf, "約", "")
　　Buf = Replace(Buf, ",", "")
　End If
　If Val(Buf) > 0 Then
　　rng.Offset(, 1).Value = "○"
　　rng.Offset(, 2).Value = Val(Buf)
　Else
　　rng.Offset(, 1).Value = "×"
　End If
End Sub

データ件数を1.2件にして、 Debug.Print Buf　を有効にして実行してみてください。

お礼

回答ありがとうございました。
うまく出来ました！
本当にありがとうございました。