■教えて！gooユーザープロフィール取得1

#2010.04.22 追記
【oshiete1.goo.ne.jpのサイト仕様変更の為、現在では本記事のコードは機能しません】

教えて！gooを利用してますが、自分の回答履歴を参照できるので、結構便利です。
反省する時に大いに役立ちます :D

そこで、履歴リストを"MSXML2.ServerXMLHTTP"を使って高速に取得するコード。
自分がわかってりゃいいので雑ですがサンプルとして。

（実行後イメージ）

Option Explicit

Const field = "cnt priolit teama category time questioner status anser url"
Const sU0 = "http://oshiete1.goo.ne.jp/user.php3?u="
Const sU1 = "&astart="
Const sU3 = "&qpt=#KOTAERU"
Const rx As Long = 10
Const cx As Long = 9
Dim sxm　As Object 'MSXML2.ServerXMLHTTP
Dim reg　As Object 'VBScript.RegExp
Dim dic　As Object 'Scriping.Dictionary
Dim rMax As Long　 '回答数
Dim buf()　　　　　'データ格納用配列
'---------------------------------------------------------------------
Sub try_goo()
　　'引数 outSht:出力シート名, uID:ユーザーID,Optional p:取得回答数
　　Call getSvrXMLgoo(Sheets.Add, 510433)
End Sub
'---------------------------------------------------------------------
Sub getSvrXMLgoo(ByVal ws As Worksheet, _
　　　　　　　　 ByVal uID As Long, _
　　　　　　　　 Optional ByVal p As Long)
　　Dim urL　 As String 'URLアドレス
　　Dim chk　 As String 'テーブル判断項目htmlTEXT
　　Dim ret　 As String 'XMLHTTP.responsetext
　　Dim st(3) As String 'URL構成文字列
　　Dim dt(2) As String 'ヘッダー用
　　Dim cnt　 As Long　 'データCOUNT
　　Dim n　　 As Long
　　Dim i　　 As Long
　　Dim v

　　Set sxm = Nothing
　　On Error Resume Next
　　Set sxm = CreateObject("MSXML2.ServerXMLHTTP")
　　On Error GoTo 0
　　If sxm Is Nothing Then Exit Sub

　　st(0) = sU0 & uID
　　st(1) = sU1
　　st(2) = 0
　　st(3) = sU3

　　urL = Join(st, "")
　　'XMLHTTP
　　ret = getXMLs(urL, "<")
　　If ret = "err" Then GoTo errOut

　　For Each v In Array("<title>", "<th>回答数</th>" & vbLf & "<td>", _
　　　　　　　　　　　　"<th>ありがとうポイント</th>" & vbLf & "<td>")
　　　　n = InStr(ret, v)
　　　　If n > 0 Then
　　　　　　ret = Mid$(ret, n + Len(v))
　　　　　　n = InStr(ret, "<")
　　　　　　dt(i) = Mid$(ret, 1, n - 1)
　　　　End If
　　　　i = i + 1
　　Next

　　rMax = Val(dt(1))
　　If rMax = 0 Then GoTo errOut
　　If p > 0 And p < rMax Then
　　　　rMax = p
　　End If
　　ReDim buf(1 To rMax, 1 To cx)

　　'1ページ目取得
　　chk = "<th class=""ok_list_entry"">回答</th>"
　　n = InStr(ret, chk)
　　If n > 0 Then
　　　　ret = Mid$(ret, n + Len(chk))
　　End If

　　Set reg = CreateObject("VBScript.RegExp")
　　reg.Global = True
　　Set dic = CreateObject("Scripting.Dictionary")

　　'RegExp
　　Call matchToV(ret, cnt)

　　'2ページ目以降の取得
　　On Error GoTo errOut
　　For i = 1 To (rMax - 1) ¥ 10
　　　　st(2) = i * 10
　　　　urL = Join(st, "")
　　　　'XMLHTTP
　　　　ret = getXMLs(urL, chk)
　　　　If ret = "err" Then Exit For
　　　　'RegExp
　　　　Call matchToV(ret, cnt)
　　Next

errOut:
　　If cnt > 0 Then
　　　　With ws
　　　　　　.Columns(3).NumberFormat = "@"
　　　　　　.Range("A1:C1").Value = dt
　　　　　　.Range("A2:I2").Value = Split(field)
　　　　　　.Range("A3").Resize(cnt, cx).Value = buf
　　　　　　.Columns("A:I").AutoFit
　　　　End With
　　End If

　　Set dic = Nothing
　　Set reg = Nothing
　　Set sxm = Nothing
　　Set ws = Nothing
End Sub

#また10,000文字制限に引っ掛かっちゃった XD　 2 へ