■教えて！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 へ

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

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

# 1 の続き...

Function getXMLs(ByVal urL As String, ByVal chk As String) As String
　　Dim ret As String
　　Dim n　 As Long

　　ret = "err"
　　sxm.Open "GET", urL, False
　　sxm.Send
　　If (sxm.Status >= 200) And (sxm.Status < 300) Then
　　　　ret = sxm.responsetext
　　　　n = InStr(ret, chk)
　　　　If n > 0 Then
　　　　　　ret = Mid$(ret, n + Len(chk))
　　　　End If
　　End If
　　getXMLs = ret
End Function
'---------------------------------------------------------------------
Sub matchToV(ByVal ret As String, ByRef cnt As Long)
　　'データ抜き出しパターン1
　　Const PTN1 = ">([^<>¥n]+)<"
　　'データ抜き出しパターン2
　　Const PTN2 = "<td class=""ok_list_content""><a href=""([^<>¥n]+)"">"
　　Dim mc1 As Object 'RegExp.Match
　　Dim mc2 As Object 'RegExp.Match
　　Dim x　 As Long
　　Dim y　 As Long
　　Dim i　 As Long
　　Dim j　 As Long
　　Dim k　 As Long
　　Dim idx As Long
　　Dim flg As Boolean
　　Dim key As String

　　reg.Pattern = PTN1
　　Set mc1 = reg.Execute(ret)
　　reg.Pattern = PTN2
　　Set mc2 = reg.Execute(ret)
　　x = 0
　　y = 0
　　k = rMax - cnt
　　If k > rx Then k = rx

　　For i = 1 To k
　　　　flg = False
　　　　key = Left$(mc2(y).submatches(0), 14)

　　　　If dic.exists(key) Then
　　　　　　idx = dic(key)
　　　　　　flg = True
　　　　Else
　　　　　　cnt = cnt + 1
　　　　　　idx = cnt
　　　　　　dic(key) = idx
　　　　　　buf(idx, 1) = idx
　　　　End If

　　　　For j = 2 To cx - 1
　　　　　　If j = 7 Then
　　　　　　　　If Not flg Or (buf(idx, 7) <> "良回答あり") Then
　　　　　　　　　　buf(idx, 7) = mc1(x).submatches(0)
　　　　　　　　End If
　　　　　　Else
　　　　　　　　buf(idx, j) = mc1(x).submatches(0)
　　　　　　End If
　　　　　　x = x + 1
　　　　　　If j = 3 Then
　　　　　　　　Do
　　　　　　　　　　If Not mc1(x + 1).submatches(0) Like "*&gt;*" Then
　　　　　　　　　　　　Exit Do
　　　　　　　　　　End If
　　　　　　　　　　x = x + 2
　　　　　　　　Loop
　　　　　　End If
　　　　Next

　　　　buf(idx, 5) = "20" & buf(idx, 5)
　　　　buf(idx, cx) = "http://oshiete1.goo.ne.jp/" & key
　　　　y = y + 1
　　Next

　　Set mc1 = Nothing
　　Set mc2 = Nothing
End Sub