■VBA XMLHTTP.responseText

#昨日のおまけみたいなもので
昨日のコードで作成されるシートのB列、http://oshiete.goo.ne.jp..URLアドレス文字列を選択して実行。
Q&Aページを簡易的に閲覧します。

Sub try()
　　Const PTN = ">([^<>]+)<"
　　Const CK0 = "<div class=""q-title"">"
　　Const CK1 = "<!-- google_ad_section_end(name=s1) -->"
　　Dim msx　As Object 'MSXML2.ServerXMLHTTP
　　Dim reg　As Object 'VBScript.RegExp
　　Dim mc　 As Object 'RegExp.Matches
　　Dim m　　As Object 'RegExp.Matches.SubMatches
　　Dim sUrL As String 'URLアドレス(ActiveCell.Value)
　　Dim ret　As String 'responsetext
　　Dim tmp　As String
　　Dim v()　As String
　　Dim n　　As Long
　　Dim i　　As Long
　　Dim flg　As Boolean

　　sUrL = ActiveCell.Value & "?order=asc"
　　If Not sUrL Like "http://oshiete.goo.ne.jp*" Then
　　　　MsgBox "select error": Exit Sub
　　End If

　　On Error Resume Next
　　Set msx = CreateObject("MSXML2.ServerXMLHTTP")
　　On Error GoTo 0
　　If msx Is Nothing Then
　　　　MsgBox "xlm error": Exit Sub
　　End If

　　On Error GoTo exitLine
　　msx.Open "GET", sUrL, False
　　msx.Send
　　If (msx.Status >= 200) And (msx.Status < 300) Then
　　　　ret = msx.responseText
　　　　n = InStr(ret, CK0)
　　　　If n > 0 Then
　　　　　　ret = Mid$(ret, n)
　　　　　　n = InStrRev(ret, CK1)
　　　　　　If n > 0 Then
　　　　　　　　ret = Left$(ret, n)
　　　　　　　　Set reg = CreateObject("VBScript.RegExp")
　　　　　　　　reg.Global = True
　　　　　　　　reg.Pattern = "<span>"
　　　　　　　　ret = reg.Replace(ret, vbLf)
　　　　　　　　reg.Pattern = PTN
　　　　　　　　Set mc = reg.Execute(ret)
　　　　　　　　If mc.Count > 0 Then
　　　　　　　　　　ReDim v(0 To mc.Count)
　　　　　　　　　　i = 0
　　　　　　　　　　reg.Pattern = "[^\s\n\r]"
　　　　　　　　　　For Each m In mc
　　　　　　　　　　　　tmp = m.submatches(0)
　　　　　　　　　　　　If Not reg.test(tmp) Then
　　　　　　　　　　　　　　tmp = Replace$(tmp, " ", "")
　　　　　　　　　　　　End If
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　　　v(i) = tmp
　　　　　　　　　　Next
　　　　　　　　　　ret = Join(v, "")
　　　　　　　　　　'文字参照置換
　　　　　　　　　　reg.Pattern = "&quot;"
　　　　　　　　　　ret = reg.Replace(ret, """")
　　　　　　　　　　reg.Pattern = "&gt;"
　　　　　　　　　　ret = reg.Replace(ret, ">")
　　　　　　　　　　reg.Pattern = "&lt;"
　　　　　　　　　　ret = reg.Replace(ret, "<")
　　　　　　　　　　reg.Pattern = "&amp;"
　　　　　　　　　　ret = reg.Replace(ret, "&")
　　　　　　　　　　reg.Pattern = "\n+"
　　　　　　　　　　ret = reg.Replace(ret, vbLf)
　　　　　　　　　　Debug.Print ret
　　　　　　　　　　'実際にはUserForm.TextBoxなどに表示
　　　　　　　　　　'With UserForm1.TextBox1
　　　　　　　　　　'　　.Text = ret
　　　　　　　　　　'　　.SelStart = 0
　　　　　　　　　　'　　.SetFocus
　　　　　　　　　　'End With
　　　　　　　　　　'UserForm1.Show 0
　　　　　　　　　　flg = True
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　End If

exitLine:
　　Erase v
　　Set mc = Nothing
　　Set reg = Nothing
　　Set msx = Nothing
　　If Not flg Then
　　　　With Err()
　　　　　　If .Number = 0 Then
　　　　　　　　ret = "NG"
　　　　　　Else
　　　　　　　　ret = .Number & "::" & .Description
　　　　　　End If
　　　　End With
　　　　MsgBox ret
　　End If
End Sub

#正規表現（は|も）勉強不足です..すみませんorz

#2010.12.09修正
'文字参照置換のところ修正しました。
>reg.Pattern = "&"
>ret = reg.Replace(ret, "&")
ってなんのことやら...orz

#2010.12.20こっそり修正
#"&amp;"の置換はアトよね...orz