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