EXCEL VBA．利用〔XMLHTTP〕擷取〔知識＋〕〔個人首頁〕相關資訊
＜．准提部林．＞
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
範例檔簡介：
■共用變數宣告：
Public xR As Range, QcURL$, uTxt$, T1$, T2$, GetTxt$, uChkInfo&
Const YahooURL$ = ""
■程式碼１：
Sub 取得個人資料()
Dim TmpTxt
If xR = "" Then Exit Sub
xR = UCase(xR)
If Not xR Like "[A-Z][A-Z]########" Then _
xR(1, 2) = "＜ID格式錯誤＞": Exit Sub
TmpTxt = Array("", "＜不公��＞", "＜不公開＞", "不公開", "不接受")
QcURL = YahooURL & "/my/my?show=" & xR
Call 取得網頁原始碼
TmpTxt(0) = QcURL
If InStr(uTxt, "這個知識檔案目前不公開。") > 0 Then GoTo 909
If InStr(uTxt, xR & """>發問記錄<") = 0 Then _
xR(1, 2) = "＜找不到網頁＞": Exit Sub
TmpTxt(3) = "公開"
T1 = "<h3>": T2 = " 的知識檔案</h3>": Call 擷取文字
TmpTxt(1) = GetTxt
T1 = "class=""level"">": T2 = "</a></h6>": Call 擷取文字
TmpTxt(2) = "( " & GetTxt & " )"
QcURL = YahooURL & "/my/mailto_profile?kid=" & xR
Call 取得網頁原始碼
If InStr(uTxt, "對方不接受網友來信") > 0 Then
TmpTxt(4) = "不接受"
ElseIf InStr(uTxt, "您不接受網友來信") > 0 Then
TmpTxt(4) = "( 不明 )"
Else
TmpTxt(4) = "接受"
End If
909:
xR(1, 2).Resize(1, 5) = TmpTxt
xR.Hyperlinks.Add Anchor:=Union(xR(1, 2), xR(1, 3)), Address:=TmpTxt(0)
End Sub
■程式碼２：
Sub 取得網頁原始碼()
Dim uPage As Object
Set uPage = CreateObject("MSXML2.XMLHTTP")
On Error GoTo 101
With uPage
.Open "POST", QcURL, False
.send (Rnd)
uTxt = .ResponseText
End With
Set uPage = Nothing: Exit Sub
101: uTxt = ""
End Sub
■程式碼３：
Sub 擷取文字()
Dim X1&, X2&
GetTxt = ""
X1 = InStr(1, uTxt, T1)
If X1 > 0 Then X2 = InStr(X1 + Len(T1), uTxt, T2)
If X2 = 0 Then Exit Sub
GetTxt = Mid(uTxt, X1 + Len(T1), X2 - X1 - Len(T1))
End Sub
■說明：
１．〔XMLHTTP〕使用〔GET〕或〔POST〕在取得即時資訊上效果不同，
請參考檔案〔測試表〕中的５個情況，自行依需求應用。
（或參考：意見００８）
２．其他相關操作程式碼及〔註解〕請參閱下載檔。
對〔XMLHTTP〕屬性及用法尚非了透，謹如上提供參考！
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
＜範例檔＞下載點１：
＜範例檔＞下載點２：
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
留言列表
