Imports System.IO
Imports System.Net
Module Module1
''' <summary>
''' 指定Webページ内の全てのリンクを取得
''' </summary>
''' <param name="url">指定WebページのURL</param>
''' <returns>ページ内のリンクのリスト(配列)</returns>
''' <remarks></remarks>
Public Function GetUrlList(ByVal url As String) As String()
Dim p1 As Integer
Dim p2 As Integer
Dim p1_1 As Integer
Dim p1_2 As Integer
Dim p1_3 As Integer
Dim p2_1 As Integer
Dim p2_2 As Integer
' Webページ取得
Dim dat As Byte() = GetWebPage(url)
' SHIFT-JISのページの場合
Dim html As String = System.Text.Encoding.GetEncoding("SHIFT-JIS").GetString(dat)
' Webページのタグ解析
Dim url_ary As String() = New String(-1) {}
Dim stp As Integer = 0
Do
' タグ検索
p1 = html.IndexOf("<", stp)
If p1 >= 0 Then
p2 = html.IndexOf(">", stp)
If p2 >= 0 And p2 > p1 Then
stp = p2 + 1
' タグの前後のスペース削除
Dim tag As String = "<" & html.Substring(p1 + 1, p2 - p1 - 1).Trim & ">"
' リンクを取得する変数を初期化
Dim ref As String = ""
' aタグ検索
p1_1 = tag.ToLower.IndexOf("<" & "a")
If p1_1 >= 0 Then
' hrefタグ検索
p1_2 = tag.ToLower.IndexOf("href", p1_1)
p1_3 = tag.ToLower.IndexOf(">", p1_1)
If p1_3 < 0 Then p1_3 = p1_2 + 1
If p1_2 >= 0 And p1_2 > p1_1 And p1_2 < p1_3 Then
p1_1 = p1_2
If p1_1 >= 0 Then
' リンク取得
p1_1 = p1_1 + "href".Length
ref = tag.Substring(p1_1)
ref = ref.TrimStart(New Char() {" "})
If ref.Substring(0, 1) <> "=" Then
ref = ""
End If
ref = ref.TrimStart(New Char() {"=", " ", "'", """"})
p2_1 = ref.IndexOf("""")
p2_2 = ref.IndexOf("'")
If p2_2 >= 0 And p2_1 > p2_2 Then p2_1 = p2_2
p2_2 = ref.IndexOf(">")
If p2_2 >= 0 And p2_1 > p2_2 Then p2_1 = p2_2
If p2_1 >= 0 Then
ref = ref.Substring(0, p2_1).Trim
Else
ref = ""
End If
End If
End If
End If
If ref <> "" Then
' 相対URLを絶対URLに変換
If ref.IndexOf("http://") < 0 And _
ref.IndexOf("https://") < 0 And _
ref.IndexOf("javaScript:") < 0 And _
ref.IndexOf("mailto:") < 0 Then
ref = url & ref
End If
' ページ内のリンクのリスト(配列)追加
ReDim Preserve url_ary(UBound(url_ary) + 1)
url_ary(UBound(url_ary)) = ref
End If
Else
stp = p1
End If
Else
Exit Do
End If
Application.DoEvents()
Loop
' 重複URLチェック
For i As Integer = 0 To UBound(url_ary) - 1
For j As Integer = i + 1 To UBound(url_ary)
If url_ary(i) = url_ary(j) Then
url_ary(j) = ""
End If
Next
Next
' 重複URL削除
Dim url_ary2 As String() = New String(-1) {}
For i As Integer = 0 To UBound(url_ary) - 1
If url_ary(i) <> "" Then
ReDim Preserve url_ary2(UBound(url_ary2) + 1)
url_ary2(UBound(url_ary2)) = url_ary(i)
End If
Next
' URLソート
Array.Sort(url_ary2)
Return url_ary2
End Function
''' <summary>
''' Webページ取得
''' </summary>
''' <param name="url">Webページ取得用URL</param>
''' <returns>WebページのByte配列データ</returns>
''' <remarks></remarks>
Private Function GetWebPage(ByVal url As String) As Byte()
Dim st As Stream = Nothing
Dim wbres As WebResponse = Nothing
Try
' URI設定
Dim url_uri As New Uri(url)
' Webリクエスト
Dim wbreq As WebRequest = CType(WebRequest.Create(url), HttpWebRequest)
' HTTP圧縮(GZIP)への対応-------------------------
' CType(wbreq, System.Net.HttpWebRequest).AutomaticDecompression = _
' System.Net.DecompressionMethods.GZip
' -----------------------------------------------
CType(wbreq, HttpWebRequest).UserAgent = _
"Mozilla/4.0 (compatible; MSIE 6.0; Windows XP)"
CType(wbreq, HttpWebRequest).Headers.Add("Accept-Language", "ja")
wbres = wbreq.GetResponse()
' Webレスポンス
st = wbres.GetResponseStream()
Dim bytes As Byte()
Dim ttlSiz As Integer = 0
Dim oneSiz As Integer
Dim dat As Byte() = New Byte(-1) {}
Do
' WebページのByte配列データ取得
ReDim bytes((1024 * 100) - 1)
oneSiz = st.Read(bytes, 0, bytes.Length)
If oneSiz > 0 Then
ReDim Preserve dat(ttlSiz + oneSiz - 1)
If oneSiz <> bytes.Length Then
ReDim Preserve bytes(oneSiz - 1)
End If
bytes.CopyTo(dat, ttlSiz)
ttlSiz = ttlSiz + oneSiz
End If
Loop While (oneSiz > 0)
Return dat
Catch ex As Exception
Throw ex
Finally
If st Is Nothing = False Then
st.Close()
st = Nothing
End If
If wbres Is Nothing = False Then
wbres.Close()
wbres = Nothing
End If
End Try
End Function
End Module
★フォームモジュール(Form1.vb)
Public Class Form1
Private Sub Button1_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button1.Click
Dim url As String = "http://nonsoft.la.coocan.jp/"
Dim urls As String() = GetUrlList(url)
If UBound(urls) >= 0 Then
Process.Start(url)
Application.DoEvents()
' Sitemap.xmlファイルオープン
Dim dblPri As Double = 1.0
Dim sw As IO.StreamWriter = New IO.StreamWriter("sitemap.xml", False)
' Sitemap.xmlヘッダー部分出力
sw.WriteLine("<?xml version=""1.0"" encoding=""UTF-8""?>")
sw.WriteLine("<urlset")
sw.WriteLine(" xmlns=""http://www.sitemaps.org/schemas/sitemap/0.9""")
sw.WriteLine(" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance""")
sw.WriteLine(" xsi:schemaLocation=""http://www.sitemaps.org/schemas/sitemap/0.9")
sw.WriteLine(" http://www.sitemaps.org/schemas/sitemap/0.9/sitemap.xsd"">")
sw.WriteLine("")
' トップURL分出力
sw.WriteLine("<url>")
sw.WriteLine(" <loc>" & url & "</loc>")
sw.WriteLine(" <priority>" & dblPri.ToString("0.00") & "</priority>")
sw.WriteLine(" <lastmod>" & Now.ToString("yyyy-MM-dd") & _
"T" & Now.ToString("HH:mm:ss") & "+00:00" & "</lastmod>")
sw.WriteLine(" <changefreq>daily</changefreq>")
sw.WriteLine("</url>")
For i As Integer = 0 To UBound(urls)
' URL分出力
If urls(i).IndexOf(url) <> 0 Then Continue For
dblPri = 0.9 - (CDbl(i) * 0.9 / CDbl(UBound(urls)))
sw.WriteLine("<url>")
sw.WriteLine(" <loc>" & urls(i) & "</loc>")
sw.WriteLine(" <priority>" & dblPri.ToString("0.00") & "</priority>")
sw.WriteLine(" <lastmod>" & Now.ToString("yyyy-MM-dd") & _
"T" & Now.ToString("HH:mm:ss") & "+00:00" & "</lastmod>")
sw.WriteLine(" <changefreq>daily</changefreq>")
sw.WriteLine("</url>")
Next
' Sitemap.xmlフッター部分出力
sw.WriteLine("</urlset>")
' Sitemap.xmlファイルクローズ
sw.Close()
sw = Nothing
End If
End Sub
End Class
