グーグルに登録されているページをチェック？（２）

質問

以前こちらで質問させて頂いた者です。
以下の７，８の回答者様のコードが参考になり使用させて頂きました。
http://okwave.jp/qa/q6398307.html

少し上手くいかないようなので、もう1度質問させてください。

エクセルＡ列にはURL
Ｂ列にはグーグルで検索した時にそのURLが載っているかどうかをチェックするというものです。
検索結果に載っていれば○、載っていなければ×で判定します。

そこで、上記URLの７，８の回答者さんのコードでは、Ｂ列に○、×の判定チェック。
さらにＣ列には検索結果の数まで載せていただきました。

スピードも速くいい感じだったのですが、ちょっと問題が生じました。

それは、手動で試してみると、グーグルに登録されているにも関わらず×の判定が多々ありました。もちろん中には正確なのもあるのですが、どうして手動と違う結果になってしまったのか分からないため質問した次第です。

ちなみに５、６の回答者さんもいい感じだったのですが、途中で止まってしまい使えない状態です。

ちぇっと、わかりずらい質問で申し訳ありませんが、もしお分かりになる方がいましたらお助けください。

よろしくお願いします。

回答No.3

Wendy02 · ベストアンサー

失礼しました。原因は、すぐに分かりましたが、気になっていた、URL エンコードについては、再び調べてみました。

エラーの原因
　約○○件
と出る部分で、直接の原因は、「約」という文字が邪魔になっているのでした。
また、正しい数字が出ていませんでしたので、それも修正しました。

以下は、そのPrivate ～ End .... というひとまとまりを、全部上書きしてください。
これで様子をみてください。

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

URLencode 関数は、Google URLに使用する記号を調べ、ひと通り変換するように補完しましたが、Google エンコードは、GoogleBot に依存しているので、違う反応を示すこともあるようです。以下のエンコード関数は、Google専用です。これは、日本語モードに限定します。

'// '注:TextCompare モードをやめましたので、記号の全角半角の区別するようにしました。

Private Function UrlEncode(ByVal sText As String) As String
'For Google encode only /rev101226
Dim buf As String
Dim ar As Variant
Dim c As Variant
　　If Len(sText) = 0 Then Exit Function
　　sText = Trim(sText)
　　With CreateObject("ScriptControl")
　　　　.Language = "JScript"
　　　　buf = .CodeObject.encodeURI(sText)
　　　　ar = Array(":", ";", "/", "=", "?", "!", "#", "$", "&", "'", "(", ")", "+", ",")
　　　　For Each c In ar
　　　　　buf = Replace(buf, c, "%" & Hex(AscW(c)))
　　　　Next
　　　　UrlEncode = buf
　　End With
End Function

なお、Googleの内部ソースが変更になった場合は、この限りではありません。その場合は、ソースを取って、数字の出る部分を探してください。

今後の変更用の注意点
現在の検索の先頭部分："検索オプション</a></div><div><div id=resultStats>"
本来は、今後のために、「件」という文字を先頭から探して、遡る方法もありますが、コードとして読みにくくなるので辞めました。

なお、2列目の表示には、○以外は、×が出る場合と、「アクセスエラー」と、「?」 の三種類があります。「？」は、プログラムエラーが発生している意味です。ただ、×の中には、Google側のGooglebot エラーもあるようですが、その検出はしておりません。

コードを変えたことで、少し反応が遅くなったはずですが、これで様子をみてください。

お礼

Wendy02様

回答ありがとうございました。
本当に感謝します。
とりあえず、解決いたしました。
今後は、検索エンジンの変更がないのを祈るばかりですが、また、分からないことがあったら質問いたします。

今回はありがとうございました。

回答No.2

xls88

失礼します。
気がついた処を書いてみます。

ContentsCheck の
buf = Mid(httpLog, i + Len(STXT), 50)
j = InStr(1, buf, "件<nobr>", 1)
buf = Mid(buf, 1, j)

で得られるbufの値ですが
1)約_2,450_件（_は半角スペースの意）
2)約_30_件
3)1_件

といったような種類があります。
そのままでは
次のIf文のCLng(Val(buf))で

1)2)のような場合は0が返されるので×になります。
3)のような場合は1が返されるので○になります。

例えば
buf = Replace(Mid(buf, 1, j), "約 ", "")
のようにして余分な文字列を消去してみてください。

因みに
buf = "2,450"
の場合
CLng(Val(buf))
では2が返されるようです。

≪参考≫
Val関数
http://officetanaka.net/excel/vba/function/Val.htm

お礼

回答ありがとうございます。

参考にさせて頂きます。

回答No.1

Wendy02

前回、ちょっと触れていた内容なのですが、

>URLEncode関数は、詳しい検討はなされていません。

Private Function UrlEncode(ByVal sText As String) As String
(UTF-8の変換関数）には、不安が残っています。前回は、// : の二つしか変換されなかったはずです。つまり、URLで使用する記号には、? & などがありますが、私が検査したのは、oshietegoo.jp だけですから、単純なURLです。

違う結果になった所で、直接、Googleに入力した場合と、関数で変換した場合と、そのURLの比較していただけませんか？昔、Yahooで同じようなものは作った覚えはあるのですが、今のところ記録が残っていません。こちらで、そういう現象を探すということも不可能ではありませんが、出来れば、ご指摘していただいたほうが早いです。他の部分では、思い当たる部分がないとは言えませんが、修正したはずなのです。ただし、同じ(×)が返っても、必ずしも同じ意味でないこともあります。

補足

Wendy02さん回答ありがとうございました。

私には関数とかは良くわからないので具体的に書きます。

例えば以下のURLなのですが、グーグルで直接検索してみるとちゃんと検索されるのですが、Wendy02さんのプログラムの判定では×になってしまいます。

http://daily.xsrv.jp/takkyuu/
http://daily.xsrv.jp/takkyuu/tishiki/0001.html
http://health-care119.com/fuminsyou/

他にもいろいろなURLがあるのですが、結構このような現象があるので、今回また質問させていただきました。