GDIplusCODE


'☆クラスモジュール ieCtrlClass
Private WithEvents myIE As InternetExplorer

Public Event myNavigateError(errCode As Variant)
Public Event myNavigateComplete(ie As InternetExplorer)
Public Event myPopup(ie As InternetExplorer)
Private myUrl As String
Private navErrFlag As Boolean
Private popupIE As InternetExplorer

Public Property Let URL(newUrl As String)
  navErrFlag = False
  myUrl = newUrl
  myIE.navigate myUrl
End Property

Public Property Get URL() As String
  URL = myIE.LocationURL
End Property

Private Sub class_initialize()
'とりあえず何もする事無し
End Sub

Private Sub class_terminate()
  On Error Resume Next
  myIE.Quit
  Set myIE = Nothing
End Sub

Public Sub newIE()
  Set myIE = CreateObject("InternetExplorer.Application")
  myIE.Visible = True
End Sub

Public Property Set ie(newIE As InternetExplorer)
  Set myIE = newIE
End Property

Public Property Get ie() As InternetExplorer
  Set ie = myIE
End Property

Private Sub myIE_DocumentComplete(ByVal pDisp As Object, URL As Variant)
  If navErrFlag Then Exit Sub
  'Webで調べた完了判定条件を全て盛り込んでみた。
  If myIE.Busy = False And myIE.readyState = READYSTATE_COMPLETE And myIE.LocationURL = URL And pDisp = myIE Then
    RaiseEvent myNavigateComplete(myIE)
  End If
End Sub

Private Sub myIE_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
  'DocumentCompleteを使う
End Sub

Private Sub myIE_NavigateError(ByVal pDisp As Object, URL As Variant, Frame As Variant, StatusCode As Variant, Cancel As Boolean)
  navErrFlag = True
  Cancel = True
  myIE.Quit
  Set myIE = Nothing
  RaiseEvent myNavigateError(StatusCode)
End Sub

Private Sub myIE_NewWindow2(ppDisp As Object, Cancel As Boolean)
  If Not popupIE Is Nothing Then Exit Sub
  Set popupIE = New InternetExplorer 'WebBrowser 挙動が異なる。後者だとうまくいかない。
  Set ppDisp = popupIE
  'この方向が腑に落ちない
  'ppDisp: WebBrowser または InternetExplorer オブジェクトの IDispatch インターフェイスへのポインター。
  'このポインターに、新規または既存の web ブラウザーまたは InternetExplorer オブジェクトの IDispatch インターフェイスを設定する。
  '空のウィンドウに、ＩＥオブジェクトを設定してやる様なイメージなんだろうか
  RaiseEvent myPopup(popupIE)
End Sub

'これを生かすとシートモジュールからIEを終了し、本クラスを消そうとしたときエクセルが飛ぶ
'Private Sub myIE_OnQuit()
'  Set myIE = Nothing
'  MsgBox "Quit"
'End Sub

'☆シートモジュール（自作クラスのイベントを受けるため）
Private WithEvents myIECtrl As ieCtrlClass
Private WithEvents myPopupIECtrl As ieCtrlClass

Sub testX()
  Set myIECtrl = New ieCtrlClass
  myIECtrl.newIE
  myIECtrl.URL = "http://www.hoge.com/"
End Sub

'元のページの読み込みが終わったらポップアップのJavaScriptを起動
'無名関数だったので、泥臭い特定法になっている。
Private Sub myIECtrl_myNavigateComplete(ie As SHDocVw.InternetExplorer)
  Dim myElements As IHTMLElementCollection
  Dim i As Long
  
  Set myElements = ie.document.getElementsByTagName("A")
  For i = 0 To myElements.Length - 1
    If Left(myElements(i).href, 10) = "javascript" And InStr(myElements(i).href, "http://www.hoge.com/sub/") > 0 Then
      myElements(i).Click
    Exit For
    End If
  Next i
End Sub

Private Sub myIECtrl_myNavigateError(errCode As Variant)
  MsgBox "接続できませんでした。" & vbCrLf & CStr(errCode)
End Sub

'ポップアップを捕捉する（人手でクリックしたときも捕捉可能）
Private Sub myIECtrl_myPopup(ie As SHDocVw.InternetExplorer)
  'この時点ではie.LocationUrlは空であった
  Set myPopupIECtrl = New ieCtrlClass
  Set myPopupIECtrl.ie = ie
End Sub

'ポップアップの読込が終了したら、URLを表示する
Private Sub myPopupIECtrl_myNavigateComplete(ie As SHDocVw.InternetExplorer)
  MsgBox "読込終了" & vbCrLf & myPopupIECtrl.URL
End Sub

Private Sub myPopupIECtrl_myNavigateError(errCode As Variant)
  MsgBox "接続できませんでした。" & vbCrLf & CStr(errCode)
End Sub

Sub terminate()
  Set myPopupIECtrl = Nothing
  Set myIECtrl = Nothing
End Sub
イベントドリブンでIEを制御してみる
