WEB XMLParser(MSXML)を使いブラウザを通さずにソース情報取得
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
|
XMLHTTPクラスとXMLHttpRequestクラスの利用 |
XMLHTTPオブジェクトを生成します概要
|
<Open Method>
|
<abort Method>
|
<send Method>
|
<status Property>
<statusText Property>
|
<getResponseHeader Method>
<getAllResponseHeaders Method>
<setRequestHeader Method>
|
<responseBody Property>
<responseStream Property>
<responseText Property>
<responseXML Property>
<statusText Property>
|
<onreadystatechange Event>
<onload Event>
|
VB・VBAサンプル
Sub GetMSXML(ByRef objMSXML As Object, ByRef blnErr As Boolean) '*************************************************** 'XML_Parser(MSXML)をObject定義する '*************************************************** 'リロードを伴わずにソース情報取得 '元々はXML形式のデータのやり取りを行うもの 'XML Parser 'JavaScriptではAjax(Asynchronous JavaScript + XML) On Error Resume Next Set objMSXML = CreateObject("MSXML2.XMLHTTP") 'MSXML2Class If (Err.Number <> 0) Then Set objMSXML = CreateObject("Microsoft.XMLHTTP") If (Err.Number <> 0) Then Set objMSXML = CreateObject("MSXML.XMLHTTPRequest") End If End If On Error GoTo 0 If objMSXML Is Nothing Then blnErr = True Else blnErr = False End If End Sub Private Sub test_UserNamePassword() '********************************************* '同期 データを取得した時点で処理 '********************************************* '********************************************* '"UserName", "Password"を設置 '********************************************* Dim objMSXML As Object, blnErr As Boolean Dim strURL As String 'パラメータ strURL = "http://www.yahoo.co.jp/" Call GetMSXML(objMSXML, blnErr) If blnErr = True Then Exit Sub With objMSXML .Open "GET", strURL, False, "UserName", "Password" .send reTry: If .readyState <> 4 Then Debug.Print .readyState DoEvents GoTo reTry: Else Debug.Print .readyState End If End With End Sub Private Sub test_readyState() '********************************************* 'サーバーにリクエスト中の処理状態を取得 '********************************************* Dim objMSXML As Object, blnErr As Boolean Dim strURL As String 'パラメータ strURL = "http://www.yahoo.co.jp/" Call GetMSXML(objMSXML, blnErr) If blnErr = True Then Exit Sub With objMSXML .Open "GET", strURL, True .send reTry: If .readyState <> 4 Then Debug.Print .readyState DoEvents GoTo reTry: Else Debug.Print .readyState End If End With End Sub Private Sub test_getResponseHeader() '********************************************* 'レスポンスヘッダ取得 '********************************************* Dim objMSXML As Object, blnErr As Boolean Dim strURL As String Dim lngStatus As Long, strSRC(5) As String Dim blnRspns As Boolean 'パラメータ strURL = "http://www.yahoo.co.jp/" '全部のレスポンスヘッダ取得 =True '個別のレスポンスヘッダ取得 =False blnRspns = False Call GetMSXML(objMSXML, blnErr) If blnErr = True Then Exit Sub With objMSXML .Open "GET", strURL, True .send reTry: If .readyState <> 4 Then Debug.Print .readyState DoEvents GoTo reTry: Else Debug.Print .readyState End If lngStatus = .status If (.status < 200 Or .status >= 300) Then Debug.Print lngStatus & vbTab & strStatus Exit Sub Else Debug.Print lngStatus & vbTab & strStatus End If If blnRspns = True Then strSRC(0) = .getAllResponseHeaders Else strSRC(1) = .getResponseHeader("ETag") strSRC(2) = .getResponseHeader("Content-Length") strSRC(3) = .getResponseHeader("Keep-Alive") strSRC(4) = .getResponseHeader("Content-Type") strSRC(5) = .getResponseHeader("Last-Modified") End If Dim i As Byte For i = 0 To 5 Debug.Print strSRC(i) Next i End With End Sub Private Sub test_responseXMLText() '********************************************* 'XML又はTextで取得する '********************************************* '********************************************* 'Shift -JISをUnicodeに変換 '********************************************* Dim objMSXML As Object, blnErr As Boolean Dim strURL As String Dim lngStatus As Long, strStatus As String, strSRC As String Dim XMLTXT As Byte, blnSJIS As Boolean 'パラメータ strURL = "http://www.yahoo.co.jp/" 'パラメータ 'XMLデータ(responseXML) = 0 'TXTデータ(responseText) = 1 XMLTXT = 1 'パラメータ 'Shift-JIS の場合 = True 'Unicode の場合 = False blnSJIS = False Call GetMSXML(objMSXML, blnErr) If blnErr = True Then Exit Sub With objMSXML .Open "GET", strURL, True .send reTry: If .readyState <> 4 Then DoEvents GoTo reTry: End If lngStatus = .status strStatus = .statusText If (.status < 200 Or .status >= 300) Then Debug.Print lngStatus & vbTab & strStatus Exit Sub Else Debug.Print lngStatus & vbTab & strStatus End If If XMLTXT = 0 Then 'XML形式以外はエラーになります。 strSRC = .responseXML Else strSRC = .responseText End If If blnSJIS = True Then strSRC = StrConv(.responseBody, vbUnicode) Else strSRC = .responseText End If Debug.Print strSRC End With End Sub Private Sub test_abort() '********************************************* '中止する '********************************************* Dim objMSXML As Object, blnErr As Boolean Dim strURL As String 'パラメータ strURL = "http://www.yahoo.co.jp/" Call GetMSXML(objMSXML, blnErr) If blnErr = True Then Exit Sub With objMSXML .Open "GET", strURL, True .send reTry: If .readyState <> 4 Then Debug.Print .readyState DoEvents GoTo reTry: Else Debug.Print .readyState End If .abort MsgBox "Cancel!" End With End Sub |