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 インデックス)