ここにはいくつかの複雑な問題があります。
MSXML2.ServerXMLHTTPCOM で使用できるイベントを公開しません。したがって、 を使用してオブジェクトをインスタンス化し、そのイベントWithEventsにアタッチすることは容易ではありません。
イベントはそこにありますが、それを処理する標準の VBA の方法は機能しません。OnReadyStateChange
- イベントを処理できるモジュールは、VBA IDE を使用して作成できません。
waitForResponse()非同期リクエストを使用する場合は呼び出す必要があります（呼び出しに加えてsetTimeouts()！）timeoutイベントはありません。タイムアウトはエラーとしてスローされます。
問題 1 を解決するには:
通常、VBA クラス モジュール (ユーザー フォームまたはワークシート モジュールにも適用されます) を使用すると、次のことが可能になります。
Private WithEvents m_xhr As MSXML2.ServerXMLHTTP
したがって、次のようにイベント ハンドラーを定義できます。
Private Sub m_xhr_OnReadyStateChange()
' ...
End Sub
ではそうではありませんMSXML2.ServerXMLHTTP。これを行うと、Microsoft Visual Basic コンパイル エラー: "オブジェクトはオートメーション イベントのソースではありません" が発生します。
どうやら、イベントは COM で使用するためにエクスポートされていません。これを回避する方法があります。
onreadystatechange読み取りの署名
Property onreadystatechange As Object
したがって、オブジェクトを割り当てることができます。メソッドを使用してクラス モジュールを作成し、次のonreadystatechangeように割り当てることができます。
m_xhr.onreadystatechange = eventHandlingObject
ただし、これは機能しません。onreadystatechangeオブジェクトを期待し、イベントが発生するたびに、定義したメソッドではなく、オブジェクト自体が呼び出されます。(たとえば、ユーザー定義のどのメソッドをイベント ハンドラーとして使用するServerXMLHTTPかを知る方法はありません)。eventHandlingObject
呼び出し可能なオブジェクト、つまりデフォルトのメソッドを持つオブジェクトが必要です(すべての COM オブジェクトは 1 つだけ持つことができます)。
(例:オブジェクトは呼び出し可能です。これは の省略形であるCollectionと言えます。)myCollection("foo")myCollection.Item("foo")
問題 2 を解決するには:
デフォルトのプロパティを持つクラス モジュールが必要です。残念ながら、これらは VBA IDE を使用して作成することはできませんが、テキスト エディターを使用して作成できます。
onreadystatechangeVBA IDE で関数を含むクラス モジュールを準備する.cls右クリックでファイルにエクスポート- それをテキスト エディターで開き、
onreadystatechange署名の下に次の行を追加します。
Attribute OnReadyStateChange.VB_UserMemId = 0
- 元のクラス モジュールを削除し、ファイルから再インポートします。
これにより、変更されたメソッドが としてマークされDefaultます。オブジェクト ブラウザ (F2) に、既定のメソッドを示す小さな青い点が表示されます。
したがって、オブジェクトが呼び出されるたびに、実際にはOnReadyStateChangeメソッドが呼び出されます。
問題 3 を解決するには:
waitForResponse()の後に呼び出すだけsend()です。
m_xhr.Send
m_xhr.waitForResponse timeout
タイムアウトの場合: このメソッドを呼び出さなかった場合、リクエストは返されません。timeoutその場合、ミリ秒後にエラーがスローされます。
問題 4 を解決するには:
On Error便宜上、タイムアウト エラーをキャッチしてイベントに変換するハンドラを使用する必要があります。
すべてを一緒に入れて
オブジェクトをラップして処理する、私が作成した VB クラス モジュールを次に示しMSXML2.ServerXMLHTTPます。名前を付けて保存AjaxRequest.clsし、プロジェクトにインポートします。
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "AjaxRequest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private m_xhr As MSXML2.ServerXMLHTTP
Attribute m_xhr.VB_VarHelpID = -1
Private m_isRunning As Boolean
' default timeouts. TIMEOUT_RECEIVE can be overridden in request
Private Const TIMEOUT_RESOLVE As Long = 1000
Private Const TIMEOUT_CONNECT As Long = 1000
Private Const TIMEOUT_SEND As Long = 10000
Private Const TIMEOUT_RECEIVE As Long = 30000
Public Event Started()
Public Event Stopped()
Public Event Success(data As String, serverStatus As String)
Public Event Error(data As String, serverStatus As String, xhr As MSXML2.ServerXMLHTTP)
Public Event TimedOut(message As String)
Private Enum ReadyState
XHR_UNINITIALIZED = 0
XHR_LOADING = 1
XHR_LOADED = 2
XHR_INTERACTIVE = 3
XHR_COMPLETED = 4
End Enum
Public Sub Class_Terminate()
Me.Cancel
End Sub
Public Property Get IsRunning() As Boolean
IsRunning = m_isRunning
End Property
Public Sub Cancel()
If m_isRunning Then
m_xhr.abort
m_isRunning = False
RaiseEvent Stopped
End If
Set m_xhr = Nothing
End Sub
Public Sub HttpGet(url As String, Optional timeout As Long = TIMEOUT_RECEIVE)
Send "GET", url, vbNullString, timeout
End Sub
Public Sub HttpPost(url As String, data As String, Optional timeout As Long = TIMEOUT_RECEIVE)
Send "POST", url, data, timeout
End Sub
Private Sub Send(method As String, url As String, data As String, Optional timeout As Long)
On Error GoTo HTTP_error
If m_isRunning Then
Me.Cancel
End If
RaiseEvent Started
Set m_xhr = New MSXML2.ServerXMLHTTP60
m_xhr.OnReadyStateChange = Me
m_xhr.setTimeouts TIMEOUT_RESOLVE, TIMEOUT_CONNECT, TIMEOUT_SEND, timeout
m_isRunning = True
m_xhr.Open method, url, True
m_xhr.Send data
m_xhr.waitForResponse timeout
Exit Sub
HTTP_error:
If Err.Number = &H80072EE2 Then
Err.Clear
Me.Cancel
RaiseEvent TimedOut("Request timed out after " & timeout & "ms.")
Resume Next
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Sub
' Note: the default method must be public or it won't be recognized
Public Sub OnReadyStateChange()
Attribute OnReadyStateChange.VB_UserMemId = 0
If m_xhr.ReadyState = ReadyState.XHR_COMPLETED Then
m_isRunning = False
RaiseEvent Stopped
' TODO implement 301/302 redirect support
If m_xhr.Status >= 200 And m_xhr.Status < 300 Then
RaiseEvent Success(m_xhr.responseText, m_xhr.Status)
Else
RaiseEvent Error(m_xhr.responseText, m_xhr.Status, m_xhr)
End If
End If
End Sub
AjaxRequest インスタンス自体m_xhr.OnReadyStateChange = Meをイベント ハンドラーとして割り当てる行に注意してください。これは、既定のメソッドとしてマークすることで可能になります。OnReadyStateChange()
OnReadyStateChange()VBA IDE は「既定のメソッド」属性を保存しないため、変更を行う場合は、エクスポート/変更/再インポート ルーチンを再度実行する必要があることに注意してください。
クラスは次のインターフェースを公開します
- 方法:
HttpGet(url As String, [timeout As Long])HttpPost(url As String, data As String, [timeout As Long])Cancel()
- プロパティ
- イベント
Started()Stopped()Success(data As String, serverStatus As String)Error(data As String, serverStatus As String, xhr As MSXML2.ServerXMLHTTP)TimedOut(message As String)
ユーザーフォームなど、別のクラスモジュールで使用しますWithEvents。
Option Explicit
Private WithEvents ajax As AjaxRequest
Private Sub UserForm_Initialize()
Set ajax = New AjaxRequest
End Sub
Private Sub CommandButton1_Click()
Me.TextBox2.Value = ""
If ajax.IsRunning Then
ajax.Cancel
Else
ajax.HttpGet Me.TextBox1.Value, 1000
End If
End Sub
Private Sub ajax_Started()
Me.Label1.Caption = "Running" & Chr(133)
Me.CommandButton1.Caption = "Cancel"
End Sub
Private Sub ajax_Stopped()
Me.Label1.Caption = "Done."
Me.CommandButton1.Caption = "Send Request"
End Sub
Private Sub ajax_TimedOut(message As String)
Me.Label1.Caption = message
End Sub
Private Sub ajax_Success(data As String, serverStatus As String)
Me.TextBox2.Value = serverStatus & vbNewLine & data
End Sub
Private Sub ajax_Error(data As String, serverStatus As String, xhr As MSXML2.ServerXMLHTTP)
Me.TextBox2.Value = serverStatus
End Sub
必要に応じて機能強化を行ってください。クラスは、AjaxRequestこの質問に答える副産物に過ぎませんでした。