IE で，フレームのある WEB ページの読み込み完了まで待機する方法

Internet Explorer からの DocumentComplete イベントを受け取ることで，読み込み完了のタイミングを得ます。

※ ポーリング (polling) と言われている手法(ReadyState プロパティを繰り返しチェックする方法)もありますが，今回は使いません。また，HTMLDocument オブジェクトは，上位からたどるのではなく，イベントハンドラメソッド内で取得することになります。HTMLDocument オブジェクトを受け取る場所

主に以下の２つの仕組みを使ってコードを書きます。

 

・STEP1: Internet Explorer からのイベントを受け取る

・STEP2: イベント発生まで待機する (同期関数 と 同期オブジェクト)

 

以下のコードは，

Access フォームに コマンド ボタン (コマンド0) を１つ置き，
そのクリックイベントからプログラムの実行が開始される

という流れになっています。Access フォームを使う必要は必ずしもありませんが，イベントを受け取るにはクラス モジュール系のものを使う必要があります。解説が後に続きます。

※ 最後の方にある 補足2 で，別途クラス化しています。

Debug.Print 付き版

※ 要 Microsoft Internet Controls への参照設定。

Option Explicit


Private Declare _
Function SetForegroundWindow Lib "user32.dll" ( _
    ByVal hWnd As LongPtr _
) As Long

Private Const STATUS_WAIT_0 As Long = 0&
Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0) + 0&
Private Const QS_ALLINPUT As Long = &H4FF&

Private Const INFINITE As Long = &HFFFFFFFF     ' Infinite timeout
    
Private Declare _
Function MsgWaitForMultipleObjects Lib "user32.dll" ( _
    ByVal nCount As Long, _
    ByRef pHandles As LongPtr, _
    ByVal fWaitAll As Long, _
    ByVal dwMilliseconds As Long, _
    ByVal dwWakeMask As Long _
) As Long

Private Declare _
Function CreateEvent Lib "kernel32.dll" Alias "CreateEventW" ( _
    ByVal lpEventAttributes As LongPtr, _
    ByVal bManualReset As Long, _
    ByVal bInitialState As Long, _
    ByVal lpName As LongPtr _
) As LongPtr

Private Declare _
Function SetEvent Lib "kernel32.dll" ( _
    ByVal hEvent As LongPtr _
) As Long

Private Declare _
Function ResetEvent Lib "kernel32.dll" ( _
    ByVal hEvent As LongPtr _
) As Long

Private Declare _
Function CloseHandle Lib "kernel32.dll" ( _
    ByVal hObject As LongPtr _
) As Long

Dim m_hEvent As LongPtr     'イベントハンドル用

Dim m_targetURL As String

Dim m_topFrame As Object    '今回のトップレベルウィンドウ/フレーム

Dim WithEvents m_IE As SHDocVw.InternetExplorer

Dim m_isRunning As Boolean    ' メソッド実行中。
'

' 全入力のウィンドウメッセージを処理しつつ，
' 引数で渡されたイベントが発生するまで待機。
Public Function VBAWaitWithDoEvents( _
    ByVal hEvent As LongPtr, Optional ByVal dwMilliseconds As Long = INFINITE) As Boolean

    Const nCount As Long = 1&   ' イベントハンドルは一個。
    Dim rc As Long
    
    Do
        rc = MsgWaitForMultipleObjects(nCount, _
                                       hEvent, _
                                       0, _
                                       dwMilliseconds, _
                                       QS_ALLINPUT)
        If rc = WAIT_OBJECT_0 Then
            ' イベント発生。
            Debug.Print "WAIT_OBJECT_0"
            VBAWaitWithDoEvents = True
            Exit Function
        ElseIf rc = WAIT_OBJECT_0 + nCount Then
            ' メッセージキューに入力あり。
            Debug.Print "WAIT_OBJECT_0 + nCount"
            DoEvents
        Else
            ' 想定外の事態。
            Exit Function
        End If
    Loop
    
End Function

Private Sub m_IE_NavigateComplete2(ByVal pDisp As Object, URL As Variant)

    Debug.Print "NavigateComplete2"

    Dim iUnk As stdole.IUnknown
    Set iUnk = pDisp
    Debug.Print "pDisp As IUnknown: " & Hex$(ObjPtr(iUnk)) & vbCrLf & "URL: " & URL
    
    If m_topFrame Is Nothing Then
        ' 関連するフレームワーク郡におけるトップレベルの NavigateComplete2 イベントは
        ' 最初に発生。
        Set m_topFrame = pDisp
        Debug.Print "Set m_topFrame = pDisp"
    End If
    
End Sub

Private Sub m_IE_DocumentComplete(ByVal pDisp As Object, URL As Variant)

    Debug.Print "DocumentComplete"

    Dim iUnk As stdole.IUnknown
    Set iUnk = pDisp
    Debug.Print "pDisp As IUnknown: " & Hex$(ObjPtr(iUnk)) & vbCrLf & "URL: " & URL
    
    If pDisp Is m_topFrame Then
        Debug.Print "pDisp Is m_topFrame"
        ' 関連するフレームワーク郡におけるトップレベルの DocumentComplete イベントは
        ' 最後に発生。
        SetEvent m_hEvent           ' Event オブジェクトを signaled 状態にする。
        Set m_topFrame = Nothing
    End If
    
End Sub

Private Sub コマンド0_Click()

    If m_isRunning Then Exit Sub
    
    m_isRunning = True
    m_hEvent = CreateEvent(0, 0, 0, 0)  ' 引数二番目: auto-reset


    Set m_IE = New SHDocVw.InternetExplorer
    
    Debug.Print "m_IE: " & Hex(ObjPtr(m_IE))
    
    Dim iUnk As stdole.IUnknown
    Set iUnk = m_IE
    Debug.Print "m_IE As IUnknown: " & Hex(ObjPtr(iUnk))
    Set iUnk = Nothing    ' 早めに解放
    
    m_IE.Visible = True
    
    
    ' おまじない --- WithEvents 時は必要。
    SetForegroundWindow Application.hWndAccessApp
    SetForegroundWindow m_IE.hWnd
    
    
    m_targetURL = "http://www5f.biglobe.ne.jp/~f-lap/index.htm"
    m_IE.Navigate m_targetURL


    ' イベント発生待機
    If Not VBAWaitWithDoEvents(m_hEvent, 5000) Then
        CloseHandle m_hEvent
        m_hEvent = 0
        MsgBox "イベント発生時に想定外(タイムアウト含む)"
        Exit Sub
    End If
    
    
    MsgBox "制御復帰"
    

    CloseHandle m_hEvent
    m_hEvent = 0
    Set m_IE = Nothing  
    m_isRunning = False
    
End Sub

 

イミディエイト ペイン出力。

(WAIT_OBJECT_0 + nCount の行は，ウィンドウ メッセージがメッセージ キューに入れられたために制御が戻ってきたものです。後の方で説明します)

m_IE: 102D38
m_IE As IUnknown: B2BB038
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
NavigateComplete2
pDisp As IUnknown: B2BB038
URL: http://www5f.biglobe.ne.jp/~f-lap/index.htm
Set m_topFrame = pDisp
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
NavigateComplete2
pDisp As IUnknown: 4C31B64
URL: http://www5f.biglobe.ne.jp/~f-lap/contents.htm
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
DocumentComplete
pDisp As IUnknown: 4C31B64
URL: http://www5f.biglobe.ne.jp/~f-lap/contents.htm
WAIT_OBJECT_0 + nCount
NavigateComplete2
pDisp As IUnknown: 4C31B64
URL: http://www5f.biglobe.ne.jp/~f-lap/page_1.htm
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
DocumentComplete
pDisp As IUnknown: 4C31B64
URL: http://www5f.biglobe.ne.jp/~f-lap/page_1.htm
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
WAIT_OBJECT_0 + nCount
DocumentComplete
pDisp As IUnknown: B2BB038
URL: http://www5f.biglobe.ne.jp/~f-lap/index.htm
pDisp Is m_topFrame
WAIT_OBJECT_0

 

◆ 解説 ◆

・ STEP1: Internet Explorer からのイベントを受け取る

Internet Explorer (以下，IE) からのイベントを受け取るには，
IE への参照を入れておく変数をクラス系のモジュールで，
WithEvent を付けて変数をモジュールレベルで宣言します。
(Microsoft Internet Controls への参照設定が必要)

Dim WithEvents m_IE As SHDocVw.InternetExplorer

・ NavigateComplete2 イベント と DocumentComplete イベント

NavigateComplete2 イベントは，
ページ遷移に絡んだフレーム群の内でトップからのものが最初に発生し，
DocumentComplete イベントは，
ページ遷移に絡んだフレーム群の内でトップからのものが最後に発生します。

その仕組みを利用して，
NavigateComplete2 イベント ハンドラ メソッド(m_IE_NavigateComplete2)で 引数 pDisp を m_topFrame に保存しておいて， DocumentComplete イベント ハンドラ メソッド(m_IE_DocumentComplete)で 引数 pDisp を m_topFrame と比較することで， ページ遷移に絡んだページの全読み込みが完了したことを知ります。

Dim m_topFrame As Object    '今回のトップレベルウィンドウ/フレーム

Private Sub m_IE_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
    
    If m_topFrame Is Nothing Then
        ' 関連するフレームワーク郡におけるトップレベルの NavigateComplete2 イベントは
        ' 最初に発生。
        Set m_topFrame = pDisp
    End If
    
End Sub

Private Sub m_IE_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    
    If pDisp Is m_topFrame Then
        ' 関連するフレームワーク郡におけるトップレベルの DocumentComplete イベントは
        ' 最後に発生。
        SetEvent m_hEvent
        Set m_topFrame = Nothing
    End If
    
End Sub

以下の出力でわかるように，NavigateComplete2 で最初に呼ばれたものの pDisp As IUnknown は，DocumentComplete で最後に呼ばれたものの pDisp As IUnknown と同じインスタンスからのものだとわかります。また，今回の場合は，トップレベルのものへの遷移なので，トップレベルのフレームからの pDisp As IUnknown は IE そのものからの m_IE As IUnknown と同じになります。

m_IE: 102D38
m_IE As IUnknown: B2BB038


NavigateComplete2
pDisp As IUnknown: B2BB038
URL: http://www5f.biglobe.ne.jp/~f-lap/index.htm
Set m_topFrame = pDisp


NavigateComplete2
pDisp As IUnknown: 4C31B64
URL: http://www5f.biglobe.ne.jp/~f-lap/contents.htm


DocumentComplete
pDisp As IUnknown: 4C31B64
URL: http://www5f.biglobe.ne.jp/~f-lap/contents.htm


NavigateComplete2
pDisp As IUnknown: 4C31B64
URL: http://www5f.biglobe.ne.jp/~f-lap/page_1.htm


DocumentComplete
pDisp As IUnknown: 4C31B64
URL: http://www5f.biglobe.ne.jp/~f-lap/page_1.htm


DocumentComplete
pDisp As IUnknown: B2BB038
URL: http://www5f.biglobe.ne.jp/~f-lap/index.htm
pDisp Is m_topFrame
WAIT_OBJECT_0

・ Is 演算子

以下のコードは，pDisp も m_topFrame も Object 型の変数なので，Object 型どうしを比較しているように見えます。

If pDisp Is m_topFrame Then

しかし，Is 演算子は，左右のオペランド(pDisp と m_topFrame) を IUnknown 型に変換しておいて，それらの場所を比較します。

COM オブジェクトにはいくつか決まりがあり，

オブジェクトのインスタンスが同じ場合は，IUnknown 型の場所は，常に同じものでなければいけない

という決まりがあります。

Is 演算子はそれを利用して左右のオペランドが同じインスタンスからのものかを確認しています。

VBA のコードで書いてみると，(注: あくまでイメージです。)

Dim iUnk1 As stdole.IUnknown
Dim iUnk2 As stdole.IUnknown
If pDisp Is Nothing And m_topFrame Is Nothing Then
    ' これは True
ElseIf pDisp Is Nothing Or m_topFrame Is Nothing Then
    ' これは Flase
Else
    Set iUnk1 = pDisp                        ' IUnknown に型変換(QueryInterface)
    Set iUnk2 = m_topFrame                   ' IUnknown に型変換(QueryInterface)
    If ObjPtr(iUnk1) = ObjPtr(iUnk2) Then    ' IUnknown の場所を比較
        ' これは True
    Else
        ' これは Flase
    End If
End If

のような感じのコードになります。

なので，
IUnknown 型に型変換していませんが，Is 演算子で比較しているので，IUnknown 型どうしでの比較になり，その部分は正しいインスタンス比較になっています。

 

実際は，IUnknown 値の Debug.Print の箇所は NavigateComplete2 と DocumentComplete の状態をみるためにいれてあったものなので，実際には必要ありません。なので，必要なコードは以下の部分のみとなります。

Debug.Print 無し版

※ 要 Microsoft Internet Controls への参照設定。

Option Explicit


Private Declare _
Function SetForegroundWindow Lib "user32.dll" ( _
    ByVal hWnd As LongPtr _
) As Long

Private Const STATUS_WAIT_0 As Long = 0&
Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0) + 0&
Private Const QS_ALLINPUT As Long = &H4FF&

Private Const INFINITE As Long = &HFFFFFFFF     ' Infinite timeout
    
Private Declare _
Function MsgWaitForMultipleObjects Lib "user32.dll" ( _
    ByVal nCount As Long, _
    ByRef pHandles As LongPtr, _
    ByVal fWaitAll As Long, _
    ByVal dwMilliseconds As Long, _
    ByVal dwWakeMask As Long _
) As Long

Private Declare _
Function CreateEvent Lib "kernel32.dll" Alias "CreateEventW" ( _
    ByVal lpEventAttributes As LongPtr, _
    ByVal bManualReset As Long, _
    ByVal bInitialState As Long, _
    ByVal lpName As LongPtr _
) As LongPtr

Private Declare _
Function SetEvent Lib "kernel32.dll" ( _
    ByVal hEvent As LongPtr _
) As Long

Private Declare _
Function ResetEvent Lib "kernel32.dll" ( _
    ByVal hEvent As LongPtr _
) As Long

Private Declare _
Function CloseHandle Lib "kernel32.dll" ( _
    ByVal hObject As LongPtr _
) As Long

Dim m_hEvent As LongPtr     'イベントハンドル用

Dim m_targetURL As String

Dim m_topFrame As Object    '今回のトップレベルウィンドウ/フレーム

Dim WithEvents m_IE As SHDocVw.InternetExplorer

Dim m_isRunning As Boolean    ' メソッド実行中。
'

' 全入力のウィンドウメッセージを処理しつつ，
' 引数で渡されたイベントが発生するまで待機。
Public Function VBAWaitWithDoEvents( _
    ByVal hEvent As LongPtr, Optional ByVal dwMilliseconds As Long = INFINITE) As Boolean

    Const nCount As Long = 1&   ' イベントハンドルは一個。
    Dim rc As Long
    
    Do
        rc = MsgWaitForMultipleObjects(nCount, _
                                       hEvent, _
                                       0, _
                                       dwMilliseconds, _
                                       QS_ALLINPUT)
        If rc = WAIT_OBJECT_0 Then
            ' イベント発生。
            VBAWaitWithDoEvents = True
            Exit Function
        ElseIf rc = WAIT_OBJECT_0 + nCount Then
            ' メッセージキューに入力あり。
            DoEvents
        Else
            ' 想定外の事態。
            Exit Function
        End If
    Loop
    
End Function

Private Sub m_IE_NavigateComplete2(ByVal pDisp As Object, URL As Variant)

    If m_topFrame Is Nothing Then
        ' 関連するフレームワーク郡におけるトップレベルの NavigateComplete2 イベントは
        ' 最初に発生。
        Set m_topFrame = pDisp
    End If
    
End Sub

Private Sub m_IE_DocumentComplete(ByVal pDisp As Object, URL As Variant)

    If pDisp Is m_topFrame Then
        ' 関連するフレームワーク郡におけるトップレベルの DocumentComplete イベントは
        ' 最後に発生。
        SetEvent m_hEvent           ' Event オブジェクトを signaled 状態にする。
        Set m_topFrame = Nothing
    End If
    
End Sub

Private Sub コマンド0_Click()

    If m_isRunning Then Exit Sub
    
    m_isRunning = True
    m_hEvent = CreateEvent(0, 0, 0, 0)  ' 引数二番目: auto-reset


    Set m_IE = New SHDocVw.InternetExplorer  
    m_IE.Visible = True
    
    
    ' おまじない --- WithEvents 時は必要。
    SetForegroundWindow Application.hWndAccessApp
    SetForegroundWindow m_IE.hWnd
    
    
    m_targetURL = "http://www5f.biglobe.ne.jp/~f-lap/index.htm"
    m_IE.Navigate m_targetURL


    ' イベント発生待機
    If Not VBAWaitWithDoEvents(m_hEvent, 5000) Then
        CloseHandle m_hEvent
        m_hEvent = 0
        MsgBox "イベント発生時に想定外(タイムアウト含む)"
        Exit Sub
    End If
    
    
    MsgBox "制御復帰"
    

    CloseHandle m_hEvent
    m_hEvent = 0
    Set m_IE = Nothing
    m_isRunning = False
    
End Sub

IE からイベントを受け取る個所の説明は以上です。

・ STEP2: イベント発生まで待機する (同期関数 と 同期オブジェクト)

以下は，m_targetURL に入れた URL までページ遷移させるコードです。

.Naviage メソッドは引数として与えられた URL まで画面遷移してくれます。

Private Sub コマンド0_Click()

    Set m_IE = New SHDocVw.InternetExplorer  
    m_IE.Visible = True  
    
    m_targetURL = "http://www5f.biglobe.ne.jp/~f-lap/index.htm"
    m_IE.Navigate m_targetURL

    ' ここで DocumentComplete イベント発生まで待機する必要がある。
    
    Set m_IE = Nothing
    
End Sub

.Navigate 呼び出しですが，すぐに制御が戻ってくるので，イベント発生まで待機する必要があります。

待機するには，同期関数というものと同期オブジェクトというものを使用します。今回は

MsgWaitForMultipleObjects

CreateEvent --- (Event オブジェクトを作成)

という２つの関数を使用します。

 

・ MsgWaitForMultipleObjects

Private Const STATUS_WAIT_0 As Long = 0&
Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0) + 0&
Private Const QS_ALLINPUT As Long = &H4FF&

Private Const INFINITE As Long = &HFFFFFFFF     ' Infinite timeout
    
Private Declare _
Function MsgWaitForMultipleObjects Lib "user32.dll" ( _
    ByVal nCount As Long, _
    ByRef pHandles As LongPtr, _
    ByVal fWaitAll As Long, _
    ByVal dwMilliseconds As Long, _
    ByVal dwWakeMask As Long _
) As Long

MsgWaitForMultipleObjects 関数は，引数として指定された，ひとつ もしくは それ以上の同期オブジェクトが signaled な状態になるまで待機します。

２番目の引数で指定した同期オブジェクトの他に，最後の引数 dwWakeMask で値を指定することで得られる 入力イベントオブジェクト(input event object) というものが別途同期オブジェクトとして含まれることになります。その input event object は戻り値の値において，最後の同期オブジェクトという位置づけになります。つまり，戻り値が WAIT_OBJECT_0 + nCount である時，入力イベントによって制御が戻ってきたことになります。

input event object が signaled な状態になるのは，指定した種類のウィンドウメッセージがやって来た時です。

MsgWaitForMultipleObjects の代わりに MsgWaitForMultipleObjectsEx をを使う場合は，以下のような宣言になります。補足2 のクラス化内のコードではそれを使用してます。

Private Const MWMO_WAITALL As Long = &H1
Private Const MWMO_ALERTABLE As Long = &H2
Private Const MWMO_INPUTAVAILABLE As Long = &H4

Private Declare _
Function MsgWaitForMultipleObjectsEx Lib "user32.dll" ( _
    ByVal nCount As Long, _
    ByRef pHandles As LongPtr, _
    ByVal dwMilliseconds As Long, _
    ByVal dwWakeMask As Long, _
    ByVal dwFlags As Long _
) As Long

Private Const STATUS_WAIT_0 As Long = 0&
Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0) + 0&
Private Const QS_ALLINPUT As Long = &H4FF&

Private Const INFINITE As Long = &HFFFFFFFF     ' Infinite timeout

Private Const WAIT_TIMEOUT As Long = 258&
Private Const STATUS_USER_APC  As Long = &HC0&
Private Const WAIT_IO_COMPLETION As Long = STATUS_USER_APC
Private Const WAIT_FAILED As Long  = &HFFFFFFFF

 詳しい説明は MSDNページ で。

 

・ Event オブジェクト

二番目の引数に指定するオブジェクトは，同期オブジェクト(Synchronization Objects) と呼ばれているものの内，今回は Event オブジェクトというものを使用します。
以下の関数で作成できます。

Private Declare _
Function CreateEvent Lib "kernel32.dll" Alias "CreateEventW" ( _
    ByVal lpEventAttributes As LongPtr, _
    ByVal bManualReset As Long, _
    ByVal bInitialState As Long, _
    ByVal lpName As LongPtr _
) As LongPtr

まず，Event オブジェクトを作成します。

Dim m_hEvent As LongPtr  'イベントハンドル用

Private Sub コマンド0_Click()

    Set m_IE = New SHDocVw.InternetExplorer  
    m_IE.Visible = True  
    
    m_targetURL = "http://www5f.biglobe.ne.jp/~f-lap/index.htm"
    m_IE.Navigate m_targetURL

    m_hEvent = CreateEvent(0, 0, 0, 0)  ' 引数2nd auto-reset; 引数3rd 初期状態 not-signaled
    



    CloseHandle m_hEvent
    m_hEvent = 0
    Set m_IE = Nothing
    
End Sub

CreateEvent 関数から戻ってくるのは オブジェクト ハンドル と呼ばれているもので，Windows が提供しているオブジェクトたちに対しては，このオブジェクト ハンドルというものを使って操作をします。

CloseHandle は不要になったオブジェクト ハンドルを閉じるものです。

 

そして，MsgWaitForMultipleObjects 関数で待機します。

Dim m_hEvent As LongPtr       'イベントハンドル用

Private Sub コマンド0_Click()

    Set m_IE = New SHDocVw.InternetExplorer  
    m_IE.Visible = True  
    
    m_targetURL = "http://www5f.biglobe.ne.jp/~f-lap/index.htm"
    m_IE.Navigate m_targetURL

    m_hEvent = CreateEvent(0, 0, 0, 0)  ' 引数二番目 auto-reset; 引数三番目 初期状態 not-signaled
    

    Const nCount As Long = 1&   ' オブジェクト ハンドルは上記の m_hEvent 一個。
    Dim rc As Long
    rc = MsgWaitForMultipleObjects(nCount, _
                                   m_hEvent, _
                                   0, _
                                   5000, _
                                   QS_ALLINPUT)


    CloseHandle m_hEvent
    m_hEvent = 0
    Set m_IE = Nothing
    
End Sub

４つ目の引数 5000 という箇所は，タイムアウト値を 5000ミリ秒 にするという意味です。タイムアウトを設けない場合は上の方で定義してある INFINITE (&HFFFFFFFF) を指定します。

５つ目の引数 QS_ALLINPUT は，「メッセージ キューに入れられるどのメッセージも」 という指定になります。
引数の詳しい説明も MSDNページ で。

２番目の引数にオブジェクト ハンドルとして渡したオブジェクトが signaled な状態になるか，５つ目の引数での指定によって指定された入力イベントが発生するまで，MsgWaitForMultipleObjects 関数からは，制御は戻ってきません。同期オブジェクトが signaled な状態になるのを待つだけでなく，入力イベントにも対応した待機状態を alertable wait state といいます。後で説明する理由から，この待機状態になるために MsgWaitForMultipleObjects 関数のような alertable wait functions を使用することが必要です。

 

・ メッセージ キュー (message queues)

UI スレッドと呼ばれているスレッドに作成されます。スレッド作成時ではなく，GUI 関連の関数を呼び出したときに作成されます。簡単に考えると，ウィンドウを作成したりするとスレッドに対して１つ作成されます。

 

・ STA (Single-Threaded Appartments) と スレッド モデル (Threading Model)

VBA の場合で覚えておかないといけないことは以下の二つです。

VBA の場合，STA (Single-Threaded Appartment) と呼ばれている論理的な空間で動くことしか想定していないスレッド モデル (apartment threading model および main threading model) を採用した COM オブジェクトを動かすために，その STA (Single-Threaded Appartment) という論理的な空間でスレッドが実行されます。

つまり，VBA のスレッドは STA というスレッド モデルで動いています。

メモ: アパートメント(appartment) と呼ばれている論理的な空間の間でメッセージをやり取りするための仕組みとして，COM オブジェクトは隠れたウィンドウを使ってやることを採用しました。また，プロセス間通信を DDE と呼ばれるウィンドウ メッセージを利用した行う方法を採用していた歴史的経緯(16bit OS 時にはスレッドという概念が無く，その時に COM は誕生していた関係でオブジェクト内でのデータの排他制御(concurrency)を考えなくてもよかったが，32bit OS 時にスレッドが導入されたときに，データの排他制御/同時実行制御(concurrency)を考えていないそういう COM オブジェクトも問題なく動くように STA というものが導入されました)もあって，そうなっています。メッセージ キューの仕組みを利用することで，１つの COM オブジェクトに対して，コード実行が一度に１実行フロー((only one flow of control on a COM object at a time in STA)しかなされないようになっています。この仕組みによって，COM オブジェクト内のデータは排他制御(concurrency)を考えなくてもよくなります。但し，隠れたウィンドウが存在することによって，メッセージ キューが作られ，メッセージを適時処理しないといけないという問題が出てきます。UI を持つものが COM オブジェクトを利用する場合，選択肢は必然的に，この STA になります。Windows Shell で COM オブジェクトであるものも STA を想定します。

STA スレッドは隠れたウィンドウ(message-only window)を作成するため，目に見えるウィンドウを持っていなくてもウィンドウが存在します。

また，VBA の STA は メインSTA というものになります。具体的には，Office 側の UI スレッド である (メイン)STA スレッドを VBA が利用しているということで，VBA のスレッドは UI スレッド と同じものということです。

以下は，確認コード。

Option Explicit

Enum APTTYPE
    APTTYPE_CURRENT = -1
    APTTYPE_STA = 0
    APTTYPE_MTA = 1
    APTTYPE_NA = 2
    APTTYPE_MAINSTA = 3
End Enum

Enum APTTYPEQUALIFIER
    APTTYPEQUALIFIER_NONE = 0
    APTTYPEQUALIFIER_IMPLICIT_MTA = 1
    APTTYPEQUALIFIER_NA_ON_MTA = 2
    APTTYPEQUALIFIER_NA_ON_STA = 3
    APTTYPEQUALIFIER_NA_ON_IMPLICIT_MTA = 4
    APTTYPEQUALIFIER_NA_ON_MAINSTA = 5
    APTTYPEQUALIFIER_APPLICATION_STA = 6
End Enum

Private Declare _
Function CoGetApartmentType Lib "ole32.dll" ( _
    ByRef pAptType As APTTYPE, _
    ByRef pAptQualifier As APTTYPEQUALIFIER _
) As Long

Private Declare _
Function GetCurrentThreadId Lib "kernel32.dll" ( _
) As Long
'

Private Sub QueryApartmentType()
    Dim hr As Long
    Dim at As APTTYPE
    Dim atq As APTTYPEQUALIFIER
    hr = CoGetApartmentType(at, atq)
    If hr <> 0 Then Exit Sub
    
    Debug.Print at, atq, Hex(GetCurrentThreadId())
End Sub

なので，メッセージ キューが既に作成されている Office 側の UI スレッド である STA スレッドを VBA は利用しているということになります。

UI スレッドに関連付けられたメッセージ キューには，Windows のシステム(ユーザーからの入力等も含む)や自身や他のアプリケーションからメッセージが随時送られてきます(post されてきます)。

VBA では，UserForm をモーダルで表示している間や，プロセス外への呼び出しを行っている間は，モーダル ループ(modal loop)いうものが背後で実行されます。そこでは，メッセージ キュー上のメッセージを各ウィンドウ(ウィンドウ プロシージャ)へディスパッチしてくれています(送ってくれています)。但し，VBA でユーザーが作成したプロシージャが実行されている間は VBA はメッセージをディスパッチしません。その場合は，メッセージは明示的にディスパッチしないといけません。

VBA でユーザーが作成したプロシージャを実行している間もウィンドウ メッセージは送られてきます。上記のコードで言えば，コマンド0_Click プロシージャが実行されている間も送られてきます。上記イミディエイト ペインへの出力でのいくつもの WAIT_OBJECT_0 + nCount たちは，隠れたウィンドウに対して，メッセージ キューからディスパッチされたり，直接送られたりしたことによって制御が戻ってきて，出力されたものです。ウィンドウ メッセージのことは気にかけないまま，作成されたコードがずっと実行されたままになっていると，メッセージ キューにメッセージが入れられてから，現在の設定だと 5秒 以内(OS の設定によって異なるので要確認)にメッセージをディスパッチし(取り出さ)ないと (反応なし) とウィンドウに表示されて Windows から怒られてしまいます。ユーザーからはアプリケーションがあたかもフリーズしたように見えます。

なので，VBA でユーザーが作成したプロシージャの実行に時間がかかる場合は，メッセージ キューに入れられたメッセージを明示的にディスパッチしてやる必要があります。

その方法は，

DoEvents

という関数を適時呼んでやることです。

但し，注意が必要なことがあります。それは，

これを呼ぶと，メッセージ キューにたまっていたウィンドウ メッセージが処理される

ということです。ユーザーがコマンドボタンをもう１回押してたりしていると，コマンド0_Click プロシージャ がもう１回実行されてしまいます。それを避けるために，ここでは，フラグ(m_isRunning)を設けています。

Dim m_hEvent As LongPtr       ' イベントハンドル用

Dim m_isRunning As Boolean    ' メソッド実行中。

Private Sub コマンド0_Click()

    If m_isRunning Then Exit Sub
    m_isRunning = True
    
    Set m_IE = New SHDocVw.InternetExplorer  
    m_IE.Visible = True  
    
    m_targetURL = "http://www5f.biglobe.ne.jp/~f-lap/index.htm"
    m_IE.Navigate m_targetURL

    m_hEvent = CreateEvent(0, 0, 0, 0)  ' 引数二番目 auto-reset; 引数三番目 初期状態 not-signaled
    

    Const nCount As Long = 1&   ' オブジェクト ハンドルは上記の m_hEvent 一個。
    Dim rc As Long
    rc = MsgWaitForMultipleObjects(nCount, _
                                   m_hEvent, _
                                   0, _
                                   5000, _
                                   QS_ALLINPUT)


    CloseHandle m_hEvent
    m_hEvent = 0
    Set m_IE = Nothing
    m_isRunning = False

End Sub

 

・ MsgWaitForMultipleObjects の戻り値

完成コードの該当箇所

Private Const STATUS_WAIT_0 As Long = 0&
Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0) + 0&

' 全入力のウィンドウメッセージを処理しつつ，
' 引数で渡されたイベントが発生するまで待機。
Public Function VBAWaitWithDoEvents( _
    ByVal hEvent As LongPtr, Optional ByVal dwMilliseconds As Long = INFINITE) As Boolean

    Const nCount As Long = 1&   ' イベントハンドルは一個。
    Dim rc As Long
    
    Do
        rc = MsgWaitForMultipleObjects(nCount, _
                                       hEvent, _
                                       0, _
                                       dwMilliseconds, _
                                       QS_ALLINPUT)
        If rc = WAIT_OBJECT_0 Then
            ' イベント発生。
            VBAWaitWithDoEvents = True
            Exit Function
        ElseIf rc = WAIT_OBJECT_0 + nCount Then
            ' メッセージキューに入力あり。
            DoEvents
        Else
            ' 想定外の事態。
            Exit Function
        End If
    Loop
    
End Function

２番目の引数でオブジェクトを複数登録する場合(nCount と数を合わせます)で，３番目の引数が 0 (FALSE) の場合はどれか１つが signaled になっても制御が戻ってきます。その場合の戻り値は signaled になったオブジェクトを0番目始まりの位置で特定できます。3 なら 0th, 1st, 2nd, 3rd と数えて４つ目の 3rd オブジェクトが signaled になったということです。本当は，もう少し細かいのですが，詳しくは MSDN を見てください。

今回の場合は，１つしか登録しないので，戻り値が WAIT_OBJECT_0 の時，つまり 0 の時に Event オブジェクトが signaled になって制御が戻ってきたことになります。

完成コードの該当箇所 (If rc = WAIT_OBJECT_0 Then)

' 全入力のウィンドウメッセージを処理しつつ，
' 引数で渡されたイベントが発生するまで待機。
Public Function VBAWaitWithDoEvents( _
    ByVal hEvent As LongPtr, Optional ByVal dwMilliseconds As Long = INFINITE) As Boolean

    Const nCount As Long = 1&   ' イベントハンドルは一個。
    Dim rc As Long
    
    Do
        rc = MsgWaitForMultipleObjects(nCount, _
                                       hEvent, _
                                       0, _
                                       dwMilliseconds, _
                                       QS_ALLINPUT)
        If rc = WAIT_OBJECT_0 Then
            ' イベント発生。
            VBAWaitWithDoEvents = True
            Exit Function
        ElseIf rc = WAIT_OBJECT_0 + nCount Then
            ' メッセージキューに入力あり。
            DoEvents
        Else
            ' 想定外の事態。
            Exit Function
        End If
    Loop
    
End Function

そして，WAIT_OBJECT_0 + nCount の時，今回の場合だと 0 + 1 => 1 の時は，ウィンドウ メッセージが来たことによって制御が戻ってきたことになります。その場合は，上記理由から，DoEvents を呼び出して，メッセージを処理させます。

完成コードの該当箇所 (ElseIf rc = WAIT_OBJECT_0 + nCount Then)

' 全入力のウィンドウメッセージを処理しつつ，
' 引数で渡されたイベントが発生するまで待機。
Public Function VBAWaitWithDoEvents( _
    ByVal hEvent As LongPtr, Optional ByVal dwMilliseconds As Long = INFINITE) As Boolean

    Const nCount As Long = 1&   ' イベントハンドルは一個。
    Dim rc As Long
    
    Do
        rc = MsgWaitForMultipleObjects(nCount, _
                                       hEvent, _
                                       0, _
                                       dwMilliseconds, _
                                       QS_ALLINPUT)
        If rc = WAIT_OBJECT_0 Then
            ' イベント発生。
            VBAWaitWithDoEvents = True
            Exit Function
        ElseIf rc = WAIT_OBJECT_0 + nCount Then
            ' メッセージキューに入力あり。
            DoEvents     ' <--- 明示的にディスパッチ
        Else
            ' 想定外の事態。
            Exit Function
        End If
    Loop
    
End Function

 

待機している目的は，Event オブジェクトが signaled になることなので，ウィンドウ メッセージのよって制御が戻ってきた場合は，もう一度呼び出しを繰り返す必要があります。Do ... Loop に入れて繰り返します。

注意: 待機時間を正確にやるには，dwMilliseconds の値を GetTickCount 等で減らしていってやる必要があります。

 

 

以下のようなコードになります。

Dim m_hEvent As LongPtr       ' イベントハンドル用

Dim m_isRunning As Boolean    ' メソッド実行中。

Private Sub コマンド0_Click()

    If m_isRunning Then Exit Sub
    m_isRunning = True
    
    Set m_IE = New SHDocVw.InternetExplorer  
    m_IE.Visible = True  
    
    m_targetURL = "http://www5f.biglobe.ne.jp/~f-lap/index.htm"
    m_IE.Navigate m_targetURL

    m_hEvent = CreateEvent(0, 0, 0, 0)  ' 引数二番目 auto-reset; 引数三番目 初期状態 not-signaled
    

    Const nCount As Long = 1&   ' オブジェクト ハンドルは上記の m_hEvent 一個。
    Dim rc As Long
    

    Do
        rc = MsgWaitForMultipleObjects(nCount, _
                                       m_hEvent, _
                                       0, _
                                       5000, _
                                       QS_ALLINPUT)

        If rc = WAIT_OBJECT_0 Then
            ' イベント発生。
            Exit Do
        ElseIf rc = WAIT_OBJECT_0 + nCount Then
            ' メッセージキューに入力あり。
            DoEvents
        Else
            ' 想定外の事態。
            CloseHandle m_hEvent
            m_hEvent = 0
            Set m_IE = Nothing
            m_isRunning = False
            Exit Function
        End If
    Loop
      
    CloseHandle m_hEvent
    m_hEvent = 0
    Set m_IE = Nothing
    m_isRunning = False

End Sub

 

この Do ... Loop の絡みの部分は関数に切り出します。
(繰り返し方は別のパターンもあるのですが，使用する Windows API 関数が多くなってしまうので，これにしておきます。)

' 全入力のウィンドウメッセージを処理しつつ，
' 引数で渡されたイベントが発生するまで待機。
Public Function VBAWaitWithDoEvents( _
    ByVal hEvent As LongPtr, Optional ByVal dwMilliseconds As Long = INFINITE) As Boolean

    Const nCount As Long = 1&   ' イベントハンドルは一個。
    Dim rc As Long
    
    Do
        rc = MsgWaitForMultipleObjects(nCount, _
                                       hEvent, _
                                       0, _
                                       dwMilliseconds, _
                                       QS_ALLINPUT)
        If rc = WAIT_OBJECT_0 Then
            ' イベント発生。
            VBAWaitWithDoEvents = True
            Exit Function
        ElseIf rc = WAIT_OBJECT_0 + nCount Then
            ' メッセージキューに入力あり。
            DoEvents
        Else
            ' 想定外の事態。
            Exit Function
        End If
    Loop
    
End Function

 

コマンド0_Click プロシージャは，以下のようになります。

Dim m_hEvent As LongPtr       ' イベントハンドル用

Dim m_isRunning As Boolean    ' メソッド実行中。

Private Sub コマンド0_Click()

    If m_isRunning Then Exit Sub
    m_isRunning = True
    
    Set m_IE = New SHDocVw.InternetExplorer  
    m_IE.Visible = True  
    
    m_targetURL = "http://www5f.biglobe.ne.jp/~f-lap/index.htm"
    m_IE.Navigate m_targetURL

    m_hEvent = CreateEvent(0, 0, 0, 0)  ' 引数二番目 auto-reset; 引数三番目 初期状態 not-signaled
    
    ' イベント発生待機
    If Not VBAWaitWithDoEvents(m_hEvent, 5000) Then
        CloseHandle m_hEvent
        m_hEvent = 0
        MsgBox "イベント発生時に想定外(タイムアウト含む)"
        Exit Sub
    End If
    
    ' 制御が戻ってきた。
      
    CloseHandle m_hEvent
    m_hEvent = 0
    Set m_IE = Nothing
    m_isRunning = False

End Sub

 

後は，Event オブジェクトを signaled な状態にするコードを書くだけです。DocumentComplete イベント ハンドラ メソッドに SetEvent 関数を書きます。Event オブジェクトのオブジェクト ハンドルに対してこれを呼ぶと，Event オブジェクトが signaled な状態になります。そうすると，MsgWaitForMultipleObjects 関数から制御が戻ってきます。

Private Declare Function SetEvent Lib "kernel32.dll" ( _
    ByVal hEvent As LongPtr _
) As Long

Dim m_hEvent As LongPtr     'イベントハンドル用

Private Sub m_IE_DocumentComplete(ByVal pDisp As Object, URL As Variant)

    If pDisp Is m_topFrame Then
        ' 関連するフレームワーク郡のおけるトップレベルの DocumentComplete イベントは
        ' 最後に発生。
        SetEvent m_hEvent           ' Event オブジェクトを signaled 状態にする。
        Set m_topFrame = Nothing
    End If
    
End Sub

 

・ "おまじない" の箇所

Dim WithEvents m_IE As SHDocVw.InternetExplorer

Set m_IE = New SHDocVw.InternetExplorer  
m_IE.Visible = True

' おまじない --- WithEvents 時は必要。
SetForegroundWindow Application.hWndAccessApp
SetForegroundWindow m_IE.hWnd

オブジェクト変数 m_IE は Internet Explorer を Automation サーバーとして参照するためのものです。イベントを受け取るために WithEvents を付けています。

IE のインスタンスを作成して，オブジェクト変数 m_IE にその参照をセットし，可視化した後，一度，アクティブな状態から外してやります。そうしないと，IE がページ状態遷移を始めないので，Access VBA では，"おまじない" としてそうしています。あくまでおまじないなので他の方法でもかまいません。Excel の UserForm ではおまじないが無くてもうまく動きます。WithEvents を付けない場合は Access VBA でも 必要ありません。

メモ: IE の既定のイベント インターフェース(outgoing interface)は  DWebBrowserEvents2 ディスパッチ インターフェース(dispatch interface)というものになります。イベント用のインターフェースのことを COM 仕様的には接続ポイント(connection point)と呼び，イベントを発生することが可能なオブジェクトのことを COM 仕様的には connectable オブジェクト と呼びます。そして，イベント ソース(source)側になります。

WithEvents 付きオブジェクト変数に参照をセットした時に，VBA が背後で，既定のイベント通知を受け取れるように，イベントを受け取るオブジェクトを IConnectionPoint::Advise を呼びだし，その接続ポイントに登録します。イベントを受け取るオブジェクトは Sink オブジェクトといいます。sink は，水の受け皿であるキッチン シンクのシンクです。イベントの受け皿ということです。

イベントのメソッドの定義は connectable オブジェクト側が行い，その実装をするのは VBA 側になります。Sink オブジェクトは outgoing interface を実装している必要があります。つまり，イベント用のディスパッチ インターフェースの IID を QueryInterface されたらインターフェース ポインタを返す必要があります。 IConnectionPoint::Advise を呼びだしときに，QueryInterface してきます。なので，IID とメソッド定義を知るために VBA 側で参照設定が必要になります。

また，接続ポイントは，ディスパッチ インターフェースというものになっているため，ディスパッチ ID (DISPID) というもので呼び出してきます。それに対処するため，あらかじめ参照設定をしておいて，タイプライブラリから DISPID を取得しておく必要があります。 参照設定をしておいて，モジュールレベルのオブジェクト変数に WithEvents を付けておけば，それらこまごましたことは VBA が背後でやってくれます。例えば，上記の DWebBrowserEvents2 の DocumentComplete イベントの DISPID は 0x00000068 (&H68&) になっていますが，DISPID が &H68& の時，上記コードの m_IE_DocumentComplete イベント プロシージャ(イベント ハンドラ メソッド ともいいます)が呼ばれるように VBA が背後でやってくれているということになります。

connectable オブジェクト側が IProvideClassInfo や特に IProvideClassInfo2 インターフェースを実装していれば，参照設定が不可能な状況，つまり，クライアント側がタイプライブラリを入手できない状況でも，接続ポイント用のディスパッチ インターフェースを実行時に取得することが可能です(VBA ではそういう仕組みがよういされていないというだけ)。

COM オブジェクト側がタイプライブラリ等で DISPID をあらかじめクライアント側に情報提供しておいてある IDispatch インターフェースのことを ディスパッチ インターフェース(dispatch interface) といいます。そして IID (インターフェース ID) が各ディスパッチ インターフェースごとにあります。インターフェースは IID で区別されるため，DISPID をあらかじめ用意していない，いわゆる 汎用 IDispatch インターフェース(IID 値が {00020400-0000-0000-C000-000000000046})とは区別されます。VBA 上で WithEvents で楽して受け取れるイベントはディスパッチ インターフェースに限定されます。

イベント(outgoing)系でないインターフェース，つまり，クライアント側から呼び出すインターフェース(incoming interface)で ディスパッチ インターフェース となっているインターフェースのうち代表的なものには，Excel の Range 型 があります。

VBA での型で，汎用 IDispatch インターフェースに相当するのものは Object 型になります。

 

・ HTMLDocument オブジェクトを受け取る場所

各フレーム内の HTMLDocument オブジェクトを受け取るには，上記コードの m_IE_DocumentComplete 内で受け取ります。他のフレームを意識せずに受け取れます。

※ 要 Microsoft HTML Object Library への参照設定。

Dim m_topFrame As Object    '今回のトップレベルウィンドウ/フレーム

Private Sub m_IE_DocumentComplete(ByVal pDisp As Object, URL As Variant)
On Error GoTo Err_h

    ' オートメーション エラーで落ちることがあるので，型に互換があるか？を念のため確認します。
    If TypeOf pDisp Is SHDocVw.InternetExplorer Then
        Dim ie As SHDocVw.InternetExplorer
        Set ie = pDisp
        ' オートメーション エラーで落ちることがあるので，型に互換があるか？を念のため確認します。
        If TypeOf ie.Document Is MSHTML.HTMLDocument Then
            Dim doc As MSHTML.HTMLDocument
            Set doc = ie.Document     ' ここでならば，フレームを意識せずに受け取れます。
        End If
    End If
    
    If pDisp Is m_topFrame Then
        ' 関連するフレームワーク郡のおけるトップレベルの DocumentComplete イベントは
        ' 最後に発生。
        SetEvent m_hEvent
        Set m_topFrame = Nothing
    End If
    
    
Ext_h:
    Exit Sub
    
Err_h:
    MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "m_IE_DocumentComplete"
    Resume Ext_h
    
End Sub

そういうページは無いとは思いますが，frame や iframe の src が "" 空だと，引数 URL は "about:blank" になります。

補足1:

F5 キー等での再読み込み時にはページ遷移とはならないので，上記イベントは発生しません。

 

IE がユーザーによって閉じられてしまった時(OnQuit イベント)の対処も必要です。

Private Sub m_IE_OnQuit()
    Set m_IE = Nothing    '握っていた IE への参照を解放しておきます。
End Sub

 

補足2:

上記のままだと利用するときに面倒なので，クラス化すると以下のような感じになります。

※ 以下のコードでは，MsgWaitForMultipleObjects の代わりに MsgWaitForMultipleObjectsEx 使用しています。

ここでは，クラス名は CIEWait とします。

CIEWait クラス

Option Explicit


Private Const MWMO_WAITALL As Long = &H1
Private Const MWMO_ALERTABLE As Long = &H2
Private Const MWMO_INPUTAVAILABLE As Long = &H4

Private Declare _
Function MsgWaitForMultipleObjectsEx Lib "user32.dll" ( _
    ByVal nCount As Long, _
    ByRef pHandles As LongPtr, _
    ByVal dwMilliseconds As Long, _
    ByVal dwWakeMask As Long, _
    ByVal dwFlags As Long _
) As Long

Private Const STATUS_WAIT_0 As Long = 0&
Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0) + 0&
Private Const QS_ALLINPUT As Long = &H4FF&

Private Const INFINITE As Long = &HFFFFFFFF     ' Infinite timeout

Private Const WAIT_TIMEOUT As Long = 258&
Private Const STATUS_USER_APC  As Long = &HC0&
Private Const WAIT_IO_COMPLETION As Long = STATUS_USER_APC
Private Const WAIT_FAILED As Long = &HFFFFFFFF

'Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" ( _
'    ByVal nCount As Long, _
'    ByRef pHandles As LongPtr, _
'    ByVal fWaitAll As Long, _
'    ByVal dwMilliseconds As Long, _
'    ByVal dwWakeMask As Long _
') As Long

Private Declare _
Function CreateEvent Lib "kernel32.dll" Alias "CreateEventW" ( _
    ByVal lpEventAttributes As LongPtr, _
    ByVal bManualReset As Long, _
    ByVal bInitialState As Long, _
    ByVal lpName As LongPtr _
) As LongPtr

Private Declare _
Function SetEvent Lib "kernel32.dll" ( _
    ByVal hEvent As LongPtr _
) As Long

Private Declare _
Function ResetEvent Lib "kernel32.dll" ( _
    ByVal hEvent As LongPtr _
) As Long

Private Declare _
Function CloseHandle Lib "kernel32.dll" ( _
    ByVal hObject As LongPtr _
) As Long

Dim m_hEvent As LongPtr     'イベントハンドル用

Dim m_topFrame As Object    '今回のトップレベルウィンドウ/フレーム

Dim WithEvents m_IE As SHDocVw.InternetExplorer
'

' 全入力のウィンドウメッセージを処理しつつ，
' 引数で渡されたイベントが発生するまで待機。
Private Function VBAWaitWithDoEvents( _
    Optional ByVal dwMilliseconds As Long = INFINITE) As Boolean

    Const nCount As Long = 1&
    
    Dim prevTime As Single
    If dwMilliseconds <> INFINITE Then
        prevTime = Timer()
    End If
    
    
    Do
        Dim rc As Long
        rc = MsgWaitForMultipleObjectsEx(nCount, _
                                         m_hEvent, _
                                         dwMilliseconds, _
                                         QS_ALLINPUT, _
                                         MWMO_ALERTABLE Or MWMO_INPUTAVAILABLE)
        If rc = WAIT_OBJECT_0 Then
            ' イベント発生。
            VBAWaitWithDoEvents = True
            Exit Function
        ElseIf rc = WAIT_OBJECT_0 + nCount Then
            ' メッセージキューに入力あり。
            DoEvents
        ElseIf rc = WAIT_TIMEOUT Then
            ' タイムアウト
            Exit Function
        ElseIf rc = WAIT_IO_COMPLETION Then
            ' APC is queued.
            DoEvents
        ElseIf rc = WAIT_FAILED Then
            ' Failed.
            Exit Function
        Else
            ' One or more mutex objects were abandoned.
            DoEvents
        End If
        
        If dwMilliseconds <> INFINITE Then
            Dim currentTime As Single
            currentTime = Timer()
            If prevTime > currentTime Then
                ' 仕切り直しとする。
                prevTime = currentTime
            End If
            dwMilliseconds = dwMilliseconds - (currentTime - prevTime) * 1000
            If dwMilliseconds <= 0 Then Exit Do
            prevTime = currentTime
        End If
    Loop
    
End Function

Private Sub Class_Initialize()
    m_hEvent = CreateEvent(0, 0, 0, 0)
End Sub

Private Sub Class_Terminate()
    CloseHandle m_hEvent
End Sub

Private Sub m_IE_NavigateComplete2(ByVal pDisp As Object, URL As Variant)

    If m_topFrame Is Nothing Then
        ' 関連するフレームワーク郡におけるトップレベルの NavigateComplete2 イベントは
        ' 最初に発生。
        Set m_topFrame = pDisp
    End If
    
End Sub

Private Sub m_IE_DocumentComplete(ByVal pDisp As Object, URL As Variant)

    If pDisp Is m_topFrame Then
        Debug.Print "m_IE_DocumentComplete"
        ' 関連するフレームワーク郡におけるトップレベルの DocumentComplete イベントは
        ' 最後に発生。
        SetEvent m_hEvent           ' Event オブジェクトを signaled 状態にする。
        Set m_topFrame = Nothing
    End If
    
End Sub

Public Property Set ie(ByVal ie As SHDocVw.InternetExplorer)
    Set m_IE = ie
End Property

Public Function WaitIE(Optional ByVal dwMilliseconds As Long = INFINITE, _
                       Optional ByVal Release As Boolean = False) As Boolean
    If m_IE Is Nothing Then
        MsgBox "InternetExplorerオブジェクトが設定されていません。"
        Exit Function
    End If
    WaitIE = VBAWaitWithDoEvents(dwMilliseconds)
    If Release Then
        Set m_IE = Nothing
    End If
End Function

以下は，上記クラス( CIEWait )を利用したコード。

Option Explicit

Dim m_isRunning As Boolean

Private Sub コマンド1_Click()

    If m_isRunning Then Exit Sub
    m_isRunning = True
    
    Dim objIE As SHDocVw.InternetExplorer
    Set objIE = New SHDocVw.InternetExplorer
    
    Dim ieWait As CIEWait
    Set ieWait = New CIEWait
    Set ieWait.ie = objIE
    
    objIE.Navigate "http://www5f.biglobe.ne.jp/~f-lap/index.htm"
    
    If Not ieWait.WaitIE() Then
        MsgBox "待機に失敗。"
        m_isRunning = False
        Exit Sub
    End If
    
    Debug.Print "After ieWait.WaitIE()"
    
    If Not objIE.Visible Then
        objIE.Visible = True
    End If
    
    m_isRunning = False
    
End Sub

注: Click 等 HTML へ対してアクションを起こす時は，Document オブジェクトの内容が入れ替わるれるように，非可視にする(objIE.Visible = False)等でフォーカスを外してやる必要があるときがあります。

 

 

 

用語について:

オブジェクト: 文脈によって以下のように異なる。
・ COM の文脈では COM オブジェクトを指す。VBA では，固有オブジェクト型 もしくは 汎用オブジェクト型の変数を使って COM オブジェクトの参照を扱う。
・ Windows の文脈では Windows が提供する各オブジェクト(Event オブジェクト や Window オブジェクト等)を指す。VBA では，Long もしくは LongPtr 型の変数を使ってそれらオブジェクトのハンドルを扱う。

クライアント: COM の文脈では COM オブジェクトを利用する側のこと。また，COM オブジェクトのことをサーバーと表現。

UUID 値，GUID 値, CLSID 値, IID 値: 別名として呼び方が異なっているだけで，実態はすべて同じ構造の値。VBA のユーザー定義型で表すと以下の構造になる。コメントとして付いている値は IDispatch インターフェースの IID。

' {00020400-0000-0000-C000-000000000046} 
Type IID
    Data1 As Long            ' 00020400
    Data2 As Integer         ' 0000
    Data3 As Integer         ' 0000
    Data4(0 To 7) As Byte    ' C000-000000000046
End Type

インターフェース/インターフェイス/interface: VBA 上では 型 のこと。各インターフェースの区別はインターフェース名ではなく，IID の値で区別する。

IUnknown インターフェース: VBA では stdole.IUnknown 型のこと。先頭から順に QueryInterface，AddRef，Release の３つのメソッドを持つ。VBA 上からはこれらメソッドは見えない。インターフェース上のメソッドの位置を表現する際は，通常は 0 始まりで数える。つまり，１つ目のメソッドは０番目( 0th )のメソッド，２つ目のメソッドは１番目( 1st )のメソッド，2nd, 3rd, 4th, 5th ... のように表現。

IDispatch インターフェース: VBA では Object 型のこと。IUnknown インターフェースの３つのメソッドに加えて，順に GetTypeInfoCount，GetTypeInfo，GetIDsOfNames，Invoke の計７つのメソッドを持つ。GetTypeInfoCount と GetTypeInfo は今でいうリフレクション用。インターフェースの情報を実行時に取得可能にするもの。GetIDsOfNames と Invoke はメソッド呼び出し用。GetIDsOfNames メソッドはメソッド名や引数名からメソッドの DISPID と 引数の DISPID を得るもの。Invoke メソッドは DISPID を使って実際にメソッドを呼び出すためのもの。VBA 上からはこれらメソッドは見えない。この IDispatch インターフェースや IEnumVariant インターフェースや下記の dispinterface のことを Dispatch Interfaces (ディスパッチ インターフェース群)と分類。また，IDispatch インターフェースが下記の dispinterface が表すインターフェースとはインターフェース的には別物というところに注意。

ディスパッチ インターフェース(dispinterface): 実態は IDispatch インターフェースではあるが，COM オブジェクト側がタイプライブラリ等で DISPID をあらかじめクライアント側に情報提供しておいてあるインターフェースのこと。IDispatch インターフェース の IID である {00020400-0000-0000-C000-000000000046} とは別の IID 値をそれぞれが持つ。例えば，Excelの Range 型がそれに相当するが，Object 型とは IID が異なることから，別の型であるということになる。VBA 上では，Object 型が GetIDsOfNames & Invoke の２度呼びになるのに対して，各ディスパッチ インターフェースは Invoke の１度呼びになる。

 

 

Debug.Print 付き

Debug.Print 無し

CIEWait クラス

イミディエイト ペイン出力

・ STEP1: Internet Explorer からのイベントを受け取る

・ STEP2: イベント発生まで待機する (同期関数 と 同期オブジェクト)

 

 

 

 

cf.
INFO: OLE Threads Must Dispatch Messages
http://support.microsoft.com/kb/136885
INFO: Descriptions and Workings of OLE Threading Models
http://support.microsoft.com/kb/150777
The dreaded "main" threading model --- The Ole New Thing
http://blogs.msdn.com/b/oldnewthing/archive/2004/06/02/146671.aspx
How To Determine When a Page Is Done Loading in WebBrowser Control
http://support.microsoft.com/kb/q180366

 

トップへ

ホームへ

 

Published: 2013-06-14

Last Updated: 2014-04-17

つくれますの部屋

Copyright(C) 2013 Yasuharu Takahashi, All Rights Reserved.