グーグルに登録されているかをチェックする場合
エクセルの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
