urlのソースを自動で読み込み、ある文字列を検索する方法、またはツール

質問

urlのソースを自動で読み込み、ある文字列を検索する方法、またはツールを探しています。

URLが1万件ほどあります。このURLの中から、特定の文字列を含むURLのみをピックアップして一覧にしたいです。

たとえば、ブログURLが３つあったとして

http://manitame.blog115.fc2.com/blog-entry-2469.html
http://yourockmyworld829.blog88.fc2.com/blog-entry-1067.html
http://moviehunt.blog58.fc2.com/blog-entry-1323.html

上記からyoutubeを貼っているブログ記事をピックアップする…などです。
"object width"などのタグが検索できれば可能なのではと安直に思っているのですが…

htmlタグはその都度指定できる形だと幸いです

VBAも検討したのですが、プログラム言語がかけないため、理解するのに時間がかかってしまいそうです…。
どなたかお得意な方、ソースも含めご教授いただけませんでしょうか。

またはそのようなツールをご存知の方いらっしゃいましたらご教授頂けますと幸いです。
よろしくお願い致します。

回答No.3

DOUGLAS_ · ベストアンサー

別件で、
http://okwave.jp/qa/q6122446.html
の方に回答していて、とてもステキな方法を発見いたしました。

　上記の #1 Wendy02 さんがお書きのＵＲＬ
http://okwave.jp/qa/q5657350.html
にある、WinHttp ライブラリ です。

　前回答と比較してみて圧倒的にスピーディーですので、こちらでお試しになってみてください。

＃Wendy02 さん、無断借用お赦しくださいね。　　<(_ _)>

Sub KeyWord_Search()
　Dim objHTTP As Object
　Dim i As Long
　Const strKW As String = "blog"
　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　With objHTTP
　　For i = 1 To Range("A1").End(xlDown).Row
　　　.Open "GET", Cells(i, 1).Value, False
　　　.Send
　　　If .Status = 200 Then If InStr(1, .ResponseText, strKW, 1) > 0 Then Cells(i, 2).Value = "＊"
　　Next
　End With
　Set objHTTP = Nothing
End Sub

お礼

何から何まで、ありがとうございます。
前のコードよりも早くなってさらに感動しました…。

一点だけ質問良いでしょうか。頂いたコードだと
40URLくらいで実行がとまってしまう傾向にあります。

実行時エラー　　The operation timed out の文字が
デバックしてみると、

.Send

に黄色いマークがしるされていました。
ちょっとよくわからないので、自分で調べてみようと思います。。

ひとまずはお礼をさせていただきたいと思い、ベストアンサーとさせていただきました。
ありがとうございます！

回答No.4

DOUGLAS_

訂正です。
Const strKW As String = "blog"
ではなくて、
Const strKW As String = "任意の文字列"
でした。

　ここに「任意の文字列」を入れてください。

回答No.2

DOUGLAS_

＞任意の文字列をピックアップしたい場合だと、いかがでしょうか。
　そうくるか、とは予め思っておりましたので、あえて、前回答のような コード にしてみたのですが、html ソース から文字列を拾う方法はいくつも用意されておりますので、「任意の文字列」がどういう文字列かによって効率のよい方法もあろうかと存じます。

If .document.embeds.Length > 0 Then
　For j = 1 To .document.embeds.Length
　　If InStr(.document.embeds.Item(j - 1).src, "http://www.youtube.com") > 0 Then
　　　Cells(i, 2).Value = "＊"
　　　Exit For
　　End If
　Next
End If

の部分を弄ってみましょう。

---------------------------------------------

１）htmlタグ を拾いたい場合
　例えば、「<table>」という htmlタグを拾う場合は、

If .document.getElementsByTagName("table").Length > 0 Then
　Cells(i, 2).Value = "＊"
End If

だけでＯＫです。

---------------------------------------------

２）一般的な文字列の場合
objIE.document.all.Length = 0
はあり得ませんので、一番外側の「If ～ End If」は外します。

For j = 1 To .document.all.Length
　If InStr(.document.all(j - 1).outerText, "任意の文字列") > 0 Then
　　Cells(i, 2).Value = "＊"
　　Exit For
　End If
Next

のようになります。

---------------------------------------------

【（２）の説明】

　例えば、この ページ の「補足」のところを、Internet Explorer の [表示(V)] - [ソース(C)] で見てみると、
<h4 class="ThaSup_ttl"><strong>補足</strong></h4>
となっていますが、これを拾うのに、。
objIE.document.all(j - 1).～～
という形で、「～～」のところに下記の プロパティ を入れてやればＯＫです。

　「.innerText」や「.outerText」の場合は「補足」を、「.innerHTML」や「.outerHTML」の場合は「<H4 class=ThaSup_ttl><STRONG>補足</STRONG></H4>」を拾ってきます。
　ダブルコーテーション の有無にも気を付けなければならないかも知れません。

　「.innerText」と「.outerText」と、あるいは「.innerHTML」と「.outerHTML」とは、必ずしも同じ内容にはなりません。
　最近の ＷＥＢページ は、この ページ の「回答履歴」の コーナー などのように、htmlソース が

　<!--↓回答履歴 Begin-->
　<div id="history_answers" class="ok_resultlist_bor bor_l bor_r bor_b">
　　　</div><!-- /-->
　<!--↑回答履歴 End-->

だけの場合もあり、必ずしも意図する キーワード を拾ってこれない場合もあります。

回答No.1

DOUGLAS_

１）エクセル の シート の Ａ列 に「１万件」の「URL」を コピペ しておきます。
２）下記 ＶＢＡ を実行します。
３）「urlのソース」に「embed src="http://www.youtube.com」が含まれる場合、当該ＵＲＬ の右の Ｂ列に「＊」印を付けます。

＞上記からyoutubeを貼っているブログ記事をピックアップする…などです。
＞"object width"などのタグが検索できれば可能なのではと安直に思っているのですが…

　YouTube の動画を他の サイト に埋め込むときには、YouTube の 当該ページ に「動画の埋込みコードを取得」という ボタン があり、それを クリック すると 埋込みコード が得られます。

　この中から YouTube に特化された コード を抜くとすれば、「embed src="http://www.youtube.com」のあたりかなと存じます。

　ただし、お示しの ＵＲＬ の内２番目の
http://yourockmyworld829.blog88.fc2.com/blog-entry-1067.html
のページには、YouTube の動画は埋め込まれていませんが、同じ ブログ の
http://yourockmyworld829.blog88.fc2.com/blog-entry-3.html
には埋め込まれています。
　このような分については、いちいち拾いにいきませんので、悪しからず。

　また、インターネット キャッシュ を途中で クリア しないと動作が遅くなるようなこともあるのかも知れませんが、それに対する処置はしておりません。

Sub YouTube_Search()
　Dim objIE As Object
　Dim i As Long
　Dim j As Long
　Set objIE = CreateObject("InternetExplorer.Application")
　With objIE
　　For i = 1 To Range("A1").End(xlDown).Row
　　　.navigate Cells(i, 1).Value
　　　While .Busy Or .ReadyState <> 4: DoEvents: Wend
　　　If .document.embeds.Length > 0 Then
　　　　For j = 1 To .document.embeds.Length
　　　　　If InStr(.document.embeds.Item(j - 1).src, "http://www.youtube.com") > 0 Then
　　　　　　Cells(i, 2).Value = "＊"
　　　　　　Exit For
　　　　　End If
　　　　Next
　　　End If
　　Next
　End With
　objIE.Quit
　Set objIE = Nothing
End Sub

補足

ありがとうございます！
youtubeブログをピックアップできることに深く感動いたしました…。

もう一つですが、任意の文字列をピックアップしたい場合だと、いかがでしょうか。
自分でプログラムをいじってみたものの、

　　　While .Busy Or .ReadyState <> 4: DoEvents: Wend
　　　If .document.embeds.Length > 0 Then
　　　　For j = 1 To .document.embeds.Length
　　　　　If InStr(.document.embeds.Item(j - 1).src, "http://www.youtube.com") > 0 Then

このあたりかと思うのですが…解釈できずに悩んでしまっております。