WebBrowser でSitemap（サイトマップ）を作ってみる　VB2005

VB Tips And Sample（HOME）＞(VB.NET Sample インデックス)

WebBrowser でSitemap（サイトマップ）を作ってみる　VB2005


サイトマップ作成機能
　

前回の「WebBrowser VB2005」から引き続き、
今回はSitemap（サイトマップ）を作ってみる
せっかくなので、YahooやGoogleで使えるサイトマップを作成できるようにしてみる。
XMLタイプのサイトマップを作ることに決めて、
参考サイトなどを調べる。
参考サイト　http://info.search.yahoo.co.jp/archives/002859.php
ここにあらかた、サイトマップのフォーマットが書かれているのでそれを参考にする。

以下のソースは、前回のものに書き加えた箇所。
＠ITのソースをそのままコピペで使っている箇所がありますので、＠ITさん、支障があればご連絡ください。

作っている時に問題となるのが、ファイル更新日時。
この方式だと、WEBにあるファイルの更新日時を取得しないといけないのだが、それは無理？
ローカルファイルにあるものを取得する方式に変えるか迷う所。しかし、サイトマップに省略は可。
また、重要度の項目だが、XMLを編集する機能が無いと、埋めごろしか、ロジックで決めてしまうかのどちらか。
これもサイトマップに省略は可。
とどのつまり、URLのタグ内容だけあれば後は省略可能とのことなので、本来URLだけでも良いのは？と思う。

不足機能としては、URLを取得したら、そのURLのWEBページのURLも読み込んで・・・・・
のように、ずるずるとサイトを巡回するようにPGすることだが、まあゴリゴリと書けば書けるので省略。

で、実際作ってみたサイトマップがこちら（XML）になる。
robots.txtはこれ
全て省略できるところは省略してみた。
果たして効果はいかほど？

　


　　　　Private　Sub　Button6_Click(ByVal　sender　As　System.Object,　ByVal　e　As　System.EventArgs)　Handles　Button6.Click
　　　　　　　　'サイトマップ作成
 　　　　　　　　'参考サイト　http://info.search.yahoo.co.jp/archives/002859.php
　　　　　　　　'me.TextBox1.Textの最後のURLパスに拡張子が入っていれば　警告する。
 　　　　　　　　'省略
　　　　　　　　With　Me.SaveFileDialog1
　　　　　　　　　　　　'.CheckFileExists　=　True
 　　　　　　　　　　　　.OverwritePrompt　=　True
　　　　　　　　　　　　.RestoreDirectory　=　True
　　　　　　　　　　　　.FileName　=　"sitemap.xml"
　　　　　　　　　　　　.Filter　=　"XML　files　(*.xml)|*.xml|Text　files　(*.txt)|*.txt|All　files　(*.*)|*.*　"
　　　　　　　　　　　　.Title　=　"XMLサイトマップを保存する"
　　　　　　　　End　With

　　　　　　　　If　Me.SaveFileDialog1.ShowDialog()　＜＞　Windows.Forms.DialogResult.OK　Then
　　　　　　　　　　　　'OK以外であれば終了
 　　　　　　　　　　　　Exit　Sub
　　　　　　　　End　If

　　　　　　　　Dim　XmlFile　As　String　=　SaveFileDialog1.FileName
　　　　　　　　'UTF-8でエンコードする
 　　　　　　　　Dim　enc　As　System.Text.Encoding　=　System.Text.Encoding.UTF8

　　　　　　　　'書き込むXMLサイトマップ
 　　　　　　　　Dim　str　As　String

　　　　　　　　str　=　"＜?xml　version=""1.0""　encoding=""UTF-8""?＞"　&　vbCrLf
　　　　　　　　str　=　str　&　"＜urlset　xmlns=""http://www.sitemaps.org/schemas/sitemap/0.9""＞"　&　vbCrLf

　　　　　　　　str　=　str　&　MakeSitemap()

　　　　　　　　str　=　str　&　"＜/urlset＞"

　　　　　　　　'サイトマップを書き込む
 　　　　　　　　System.IO.File.WriteAllText(XmlFile,　str,　enc)

　　　　　　　　If　MessageBox.Show("XMLサイトマップを保存しました。"　&　"robots.txtも作成しますか？",　"XMLサイトマップ",　MessageBoxButtons.YesNo,　MessageBoxIcon.Question)　=　Windows.Forms.DialogResult.No　Then
　　　　　　　　　　　　Exit　Sub
　　　　　　　　End　If


　　　　　　　　'robots.txtも作成します
 　　　　　　　　With　Me.SaveFileDialog1
　　　　　　　　　　　　'.CheckFileExists　=　True
 　　　　　　　　　　　　.OverwritePrompt　=　True
　　　　　　　　　　　　.RestoreDirectory　=　True
　　　　　　　　　　　　.FileName　=　"robots.txt"
　　　　　　　　　　　　.Filter　=　"Text　files　(*.txt)|*.txt|All　files　(*.*)|*.*　"
　　　　　　　　　　　　.Title　=　"robots.txtを保存する"
　　　　　　　　End　With

　　　　　　　　Me.SaveFileDialog1.ShowDialog()

　　　　　　　　Dim　robolFile　As　String　=　SaveFileDialog1.FileName
　　　　　　　　'Shift_JIS
 　　　　　　　　Dim　encS　As　System.Text.Encoding　=　System.Text.Encoding.GetEncoding(932)
　　　　　　　　'書き込む
 　　　　　　　　Dim　strrobo　As　String
　　　　　　　　strrobo　=　"Sitemap:　"　&　Me.TextBox1.Text　&　"sitemap.xml"

　　　　　　　　'robots.txtもつくってしまう。
 　　　　　　　　'robots.txtの記述例()
 　　　　　　　　'Sitemap:　http://www.example.com/sitemap.xml
 　　　　　　　　'追加する
 　　　　　　　　System.IO.File.WriteAllText(robolFile,　strrobo,　encS)

　　　　　　　　MessageBox.Show("robots.txtを保存しました。",　"robots.txt",　MessageBoxButtons.OK,　MessageBoxIcon.Information)



　　　　End　Sub

　　　　'URLテキストからサイトマップを作っていく
 　　　　Function　MakeSitemap()　As　String
　　　　　　　　'リンク抜き出し
 　　　　　　　　Dim　i　As　Integer
　　　　　　　　Dim　UrlList()　As　String
　　　　　　　　Dim　strmap　As　String　=　""

'以下NonDispBrowserは@IT参照　http://www.atmarkit.co.jp/fdotnet/dotnettips/687nondispbrowser/nondispbrowser.html
を一部引用・使用しています。
　　　　　　　　Dim　ndb　As　New　NonDispBrowser
　　　　　　　　ndb.NavigateAndWait(Me.TextBox1.Text)

　　　　　　　　Dim　doc　As　HtmlDocument　=　ndb.Document

　　　　　　　　'　リンク文字列とそのURLの列挙
 　　　　　　　　For　Each　tage　As　HtmlElement　In　doc.GetElementsByTagName("A")

　　　　　　　　　　　　Dim　href　As　String　=　tage.GetAttribute("HREF")　'　HREF属性の値
 　　　　　　　　　　　　Dim　text　As　String　=　tage.InnerText　'　リンク文字列
　　　　　　　　　　　　If　(Not　String.IsNullOrEmpty(href))　And　(Not　String.IsNullOrEmpty(text))　Then
　　　　　　　　　　　　　　　　text　=　text.Replace(vbCrLf,　"")　'　改行文字の削除
 　　　　　　　　　　　　　　　　ReDim　Preserve　UrlList(i)　'配列の値を残したまま再定義
 　　　　　　　　　　　　　　　　UrlList(i)　=　href　'URLを入れる
 　　　　　　　　　　　　　　　　i　=　i　+　1
　　　　　　　　　　　　End　If
　　　　　　　　Next
’↑ここまで
　　　　　　　　i　=　0
　　　　　　　　Do　Until　UBound(UrlList)　=　i
　　　　　　　　　　　　'URLがサイト内のものであればサイトマップに加える
 　　　　　　　　　　　　If　InStr(UrlList(i),　Me.TextBox1.Text)　＜＞　0　Then

　　　　　　　　　　　　　　　　'既に追加しているURLでなければ追加する
 　　　　　　　　　　　　　　　　If　InStr(strmap,　UrlList(i))　=　0　Then
　　　　　　　　　　　　　　　　　　　　strmap　=　strmap　&　"＜url＞"　&　vbCrLf
　　　　　　　　　　　　　　　　　　　　strmap　=　strmap　&　"＜loc＞"　&　escape(UrlList(i))　&　"＜/loc＞"　&　vbCrLf
　　　　　　　　　　　　　　　　　　　　strmap　=　strmap　&　"＜lastmod＞"　&　Format(Now,　"yyyy-MM-dd")　&　"＜/lastmod＞"　&　vbCrLf　'ファイル更新日時　2005-01-01
　　　　　　　　　　　　　　　　　　　　strmap　=　strmap　&　"＜changefreq＞"　&　Me.ComboBox1.Text　&　"＜/changefreq＞"　&　vbCrLf　'weekly　毎週更新されるウェブページに指定します。　
　　　　　　　　　　　　　　　　　　　　strmap　=　strmap　&　"＜priority＞"　&　NumericUpDown1.Value.ToString　&　"＜/priority＞"　&　vbCrLf　'優先度　1.0　から0.0　デフォルト0.5
　　　　　　　　　　　　　　　　　　　　strmap　=　strmap　&　"＜/url＞"　&　vbCrLf
　　　　　　　　　　　　　　　　End　If
　　　　　　　　　　　　End　If
　　　　　　　　　　　　i　=　i　+　1

　　　　　　　　Loop

　　　　　　　　Return　strmap

　　　　End　Function

　　　　Private　Function　escape(ByVal　url　As　String)　As　String
'文字列などを置き換える
URL 　　　　　　　　'アンパサンド　&　&　
 　　　　　　　　'一重引用符(シングルクォート)　'　'　
 　　　　　　　　'二重引用符（ダブルクォート）　"　"　
 　　　　　　　　'不等記号（より大）　＞　>　
 　　　　　　　　'不等記号（より小）　＜　<　
　　　　　　　　'サイトの文字コードによってエンコードするのはとりあえず省略
　　　　　　　　'↓のソースはHTMLなので、正しく表示されていません。上のコメントを参考にしてください。
　　　　　　　　url　=　Replace(url,　"&",　"&")
　　　　　　　　url　=　Replace(url,　"'",　"'")
 　　　　　　　　url　=　Replace(url,　"""",　""")
　　　　　　　　url　=　Replace(url,　"＞",　">")
　　　　　　　　url　=　Replace(url,　"＜",　"<")

　　　　　　　　Return　url

　　　　End　Function



'以下NonDispBrowserは@IT参照　http://www.atmarkit.co.jp/fdotnet/dotnettips/687nondispbrowser/nondispbrowser.html
を引用・使用しています。
 Public　Class　NonDispBrowser
　　　　Inherits　WebBrowser

　　　　Dim　done　As　Boolean

　　　　'　タイムアウト時間（10秒）
 　　　　Dim　timeout　As　New　TimeSpan(0,　0,　10)

　　　　Protected　Overrides　Sub　OnDocumentCompleted(ByVal　e　As　WebBrowserDocumentCompletedEventArgs)
　　　　　　　　'　ページにフレームが含まれる場合にはフレームごとに
 　　　　　　　　'　このメソッドが実行されるため実際のURLを確認する
 　　　　　　　　If　e.Url　=　Me.Url　Then
　　　　　　　　　　　　done　=　True
　　　　　　　　End　If
　　　　End　Sub

　　　　Protected　Overrides　Sub　OnNewWindow(ByVal　e　As　CancelEventArgs)
　　　　　　　　'　ポップアップ・ウィンドウをキャンセル
 　　　　　　　　e.Cancel　=　True
　　　　End　Sub

　　　　Public　Sub　New()
　　　　　　　　'　スクリプト・エラーを表示しない
 　　　　　　　　Me.ScriptErrorsSuppressed　=　True
　　　　End　Sub

　　　　Public　Function　NavigateAndWait(ByVal　url　As　String)　As　Boolean

　　　　　　　　MyBase.Navigate(url)　'　ページの移動
　　　　　　　　done　=　False
　　　　　　　　Dim　start　As　DateTime　=　DateTime.Now

　　　　　　　　While　done　=　False
　　　　　　　　　　　　If　DateTime.Now　-　start　＞　timeout　Then
　　　　　　　　　　　　　　　　'　タイムアウト
 　　　　　　　　　　　　　　　　Return　False
　　　　　　　　　　　　End　If
　　　　　　　　　　　　Application.DoEvents()
　　　　　　　　End　While

　　　　　　　　Return　True
　　　　End　Function
End　Class




VB Tips And Sample（HOME）＞(VB.NET Sample インデックス)