FC2ブログ

VBAでWebスクレイピング AlertボックスやShowModalウインドウをやっつけろ その2

前回の
VBAでWebスクレイピング AlertボックスやShowModalウインドウをやっつけろ その1
http://hymandr1200st.blog.fc2.com/blog-entry-1230.html
つづきです

このVBAでは
1.UI通知バーへの応答
2.window.showModalDialogによるモーダルダイアログへの応答
3.Alertボックスへの応答

の要素が凝縮されています

以下のテキストを適当なVBA標準モジュールに貼り付けてください
詳しい説明は、ニーズがあれば(笑)

Option Explicit
'参照設定
'Microsoft Internet Controls
'UIAutomationClient

'---------------------------------------------------------
' WinodwDom関係
'---------------------------------------------------------
Private Declare Function RegisterWindowMessage Lib "user32" _
    Alias "RegisterWindowMessageA" _
    (ByVal lpString As String) As Long

Private Declare Function SendMessageTimeout Lib "user32" _
    Alias "SendMessageTimeoutA" _
    (ByVal hWnd As Long, _
    ByVal msg As Long, _
    ByVal wParam As Long, _
    ByRef lParam As Any, _
    ByVal fuFlags As Long, _
    ByVal uTimeout As Long, _
    ByRef lpdwResult As Long) As Long

Private Declare Function ObjectFromLresult Lib "oleacc" _
    (ByVal lResult As Long, _
    ByRef riid As UUID, _
    ByVal wParam As Long, _
    ByRef ppvObject As Any) As Long
    
Private Type UUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

'---------------------------------------------------------
' トップレベルハンドルをクラス名かタイトル名で検索
'---------------------------------------------------------
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
     ByVal lpClassName As String, _
     ByVal lpWindowName As String) As LongPtr
     
'---------------------------------------------------------
' 親ハンドルからクラス名かタイトル名で検索
'---------------------------------------------------------
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
     ByVal hwndParent As LongPtr, _
     ByVal hwndChildAfter As LongPtr, _
     ByVal lpClassName As String, _
     ByVal lpWindowName As String) As LongPtr
     
'-------------------------------------
' ハンドルのクラス名を取得
'-------------------------------------
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" _
    (ByVal hWnd As LongPtr, ByVal lpClassName As String, _
     ByVal nMaxCount As Long) As Long
     
'-------------------------------------
' ウィンドウのプロセスIDとスレッドIDを取得
'-------------------------------------
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" _
    (ByVal hWnd As LongPtr, ByRef lpdwProcessId As Long) As Long

'-------------------------------------
' 指定ハンドルにメッセージをポスト(同期)
'-------------------------------------
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
Const WM_COMMAND As Long = &H111&

'-------------------------------------
' Sleep
'-------------------------------------
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'-------------------------------------
' トップレベルウィンドウを列挙
'-------------------------------------
Private Declare PtrSafe Function EnumWindows Lib "user32" _
    (ByVal lpEnumFunc As LongPtr, ByRef lParam As ENUMWND_DATA) As Long
Private Type ENUMWND_DATA
    lngTargetProcessID As LongPtr   'プロセスID
    lngTargetThreadD As LongPtr     'スレッドID
    strTargetClassName As String    'クラス名
    lnghWnd As LongPtr              '見つけたハンドル
    strRTNMSG As String             'メッセージ
End Type

'-------------------------------------
' TestMain
'-------------------------------------
Sub TestMain()
Dim strMSG As String
Dim hWnd As LongPtr
Dim objIE As InternetExplorer
Dim strCMD
Dim lngCHhWnd As LongPtr
Dim objDoc As Object

'以下では、セキュリティー設定にもよりますが
'ローカルファイルにアクセスするにあたり
'通常のIE起動ではなくInternetExplorerMediumで起動します
'うまく説明できませんが、InternetExplorerで起動しても
'file://のuRLにナビゲートした瞬間、IEはInternetExplorerMediumにスイッチされ
'objIEは消滅して無くなったInternetExplorerしか捕捉できません
'このことは、例えばローカルなHTMLファイルに外部リンクを貼った場合でも注意が必要ということ
'外部リンクのURLをクリックした瞬間objIEはすべてを見失います
'Set objIE = New InternetExplorer
Set objIE = New InternetExplorerMedium

objIE.Visible = True
objIE.Navigate "file://C:\Users\Kororin\Desktop\popup\showModalDialog.html"
'
Do While objIE.Busy Or objIE.ReadyState < 4
    DoEvents
    Sleep 100
Loop

'IEドキュメントの状態確認
Do While objIE.Document.ReadyState <> "complete"
    DoEvents
    Sleep 100
Loop

'通知バーに応答
Do Until UIBar(objIE.hWnd)
    DoEvents
Loop

'ここでvbs起動
strCMD = "CMD /C CScript %USERPROFILE%\Desktop\popup\IECtrlSub.VBS """
strCMD = strCMD & "IEGetH " & objIE.hWnd
strCMD = strCMD & """ ""Click ID btnOpen 0"""
Dim objShell
Set objShell = CreateObject("WScript.Shell")
objShell.Run strCMD, 0

'Modalウインドウが出るまで待機
Do
    hWnd = FindModal(objIE.hWnd, "Internet Explorer_TridentDlgFrame", strMSG)
    DoEvents
Loop Until hWnd <> 0
If hWnd = -1 Then
    Exit Sub '永久誤り
End If

'Internet Explorer_TridentDlgFrameの子Internet Explorer_Serverを取得
lngCHhWnd = 0
Do
    lngCHhWnd = FindWindowEx(hWnd, lngCHhWnd, "Internet Explorer_Server", vbNullString)
    DoEvents
Loop Until lngCHhWnd <> 0
If lngCHhWnd = -1 Then
    Exit Sub '永久誤り
End If

'モダールウインドウのDom 取得
Call WindowDOM(lngCHhWnd, objDoc)
'取得したダイヤログウインドウのID「OKButton」をクリック
objDoc.getelementbyid("btnClose").Click

'alertボックスが出るまで待機
Do
    hWnd = FindModal(objIE.hWnd, "#32770", strMSG)
    DoEvents
Loop Until hWnd <> 0
If hWnd = -1 Then
    Exit Sub '永久誤り
End If

hWnd = PostMessage(hWnd, WM_COMMAND, vbCancel, 0)
 
MsgBox "End"

End Sub

'-------------------------------------
' モダールウィンドウの処理
'-------------------------------------
Private Function FindModal( _
    lngParenthWnd As LongPtr, _
    strClassName As String, _
    strRTNMSG As String _
    ) As LongPtr
    
Dim ENUM_Arg As ENUMWND_DATA
Dim RTN As Long

Dim hWnd As LongPtr
Dim CHhWnd As LongPtr

RTN = 0
hWnd = lngParenthWnd
CHhWnd = 0
strRTNMSG = ""

Do Until RTN <> 0
    'IEの子Frame Tabを取得(フレームは複数あり得る)
    CHhWnd = FindWindowEx(hWnd, CHhWnd, "Frame Tab", vbNullString)
    If CHhWnd = 0 Then
        strRTNMSG = "Frame Tab Not Found"
        FindModal = 0
        Exit Function
    End If
    'Frame Tabの子InternetToolbarHosを取得(必ずひとつあるはず)
    CHhWnd = FindWindowEx(CHhWnd, 0, "InternetToolbarHost", vbNullString)
    If CHhWnd = 0 Then
        strRTNMSG = "InternetToolbarHost Not Found"
        FindModal = 0
        Exit Function
    End If
    'InternetToolbarHostのプロセスIDとスレッドIDを取得する
    ENUM_Arg.lngTargetThreadD = GetWindowThreadProcessId(CHhWnd, ENUM_Arg.lngTargetProcessID)
    
    'WINAPIの引数に指定する文字列はAPI内部ではUNICODEで動作します
    '通常の引数は引数が渡された時点で自動変換されますが
    '独自にType指定した場合は自分でUNICODEに変換します
    ENUM_Arg.strTargetClassName = StrConv(strClassName, vbUnicode)
    
    '"#32770"または "Internet Explorer_TridentDlgFrame"
    ENUM_Arg.lnghWnd = 0
    Call EnumWindows(AddressOf EnumWindowsProc, ENUM_Arg)
    If ENUM_Arg.lnghWnd <> 0 Then
        FindModal = ENUM_Arg.lnghWnd
        Exit Function
    End If

Loop

strRTNMSG = "Can Not Found"
FindModal = -1

End Function

'-------------------------------------
' コールバック関数 - トップレベルウィンドウを列挙
'-------------------------------------
Private Function EnumWindowsProc(ByVal hWnd As Long, ByRef lParam As ENUMWND_DATA) As Long
Dim lngPrs As Long  'プロセスID
Dim lngTrd As Long  'スレッドID
Dim Buffer As String * 512 'バッファ
Dim strClassName As String 'クラス名
Dim strTargetClassName As String 'クラス名

Call GetClassName(hWnd, Buffer, Len(Buffer))

strClassName = Left(Buffer, InStr(Buffer, vbNullChar) - 1)

'Debug.Print lParam.strTargetClassName
If strClassName = lParam.strTargetClassName Then
    lngTrd = GetWindowThreadProcessId(hWnd, lngPrs)
    If (lngPrs = lParam.lngTargetProcessID) And (lngTrd = lParam.lngTargetThreadD) Then
        lParam.lnghWnd = hWnd
        EnumWindowsProc = False
        Exit Function
    End If
End If
EnumWindowsProc = True
End Function


'---------------------------------------------------------
' WinodwDom関係
'---------------------------------------------------------
Private Function WindowDOM(ByVal hWnd As Long, ByRef objDoc As Object) As Boolean ' IHTMLDocument
Dim lngMsg As Long
Dim lngRtn As Long

WindowDOM = False

lngMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
If lngMsg = 0 Then
    Exit Function
End If

Const SMTO_ABORTIFHUNG As Long = &H2
Dim lngRes As Long
SendMessageTimeout hWnd, lngMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lngRes
If lngRes = 0 Then
    Exit Function
End If


Dim IID_IHTMLDocument As UUID
With IID_IHTMLDocument
    .Data1 = &H626FC520
    .Data2 = &HA41E
    .Data3 = &H11CF
    .Data4(0) = &HA7
    .Data4(1) = &H31
    .Data4(2) = &H0
    .Data4(3) = &HA0
    .Data4(4) = &HC9
    .Data4(5) = &H8
    .Data4(6) = &H26
    .Data4(7) = &H37
End With

lngRtn = ObjectFromLresult(lngRes, IID_IHTMLDocument, 0, objDoc)
Debug.Print TypeName(objDoc)

End Function

'---------------------------------------------------------
' 通知バーの処理
'---------------------------------------------------------
Private Function UIBar(ByVal hWnd As LongPtr) As Boolean
Dim CHhWnd As LongPtr

Dim objUI As IUIAutomation2
Dim objUIElement As IUIAutomationElement
Dim iCnd As IUIAutomationCondition
Dim Button As IUIAutomationElement
Dim InvokePattern As IUIAutomationInvokePattern

UIBar = False

'捕捉しているIEのハンドルで子ハンドル"Frame Notification Bar"(通知バー)を取得
CHhWnd = FindWindowEx(hWnd, 0, "Frame Notification Bar", vbNullString)

If CHhWnd = 0 Then GoTo LabelExit

Set objUI = New CUIAutomation8

'"Frame Notification Bar"からハンドルでUIエレメントを取得
Set objUIElement = objUI.ElementFromHandle(ByVal CHhWnd)

'指定された名前をもつコレクションを取得
Set iCnd = objUI.CreatePropertyCondition(UIA_NamePropertyId, "ブロックされているコンテンツを許可")

'コレクションの先頭をボタンに取得
Set Button = objUIElement.FindFirst(TreeScope_Subtree, iCnd)

'ボタンが取得できるまで待機
Do While iCnd Is Nothing
    DoEvents
    Sleep 1
    Set Button = objUIElement.FindFirst(TreeScope_Subtree, iCnd)
Loop

Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId)
InvokePattern.Invoke '呼び出す

UIBar = True

LabelExit:

Set objUI = Nothing
Set objUIElement = Nothing
Set iCnd = Nothing
Set Button = Nothing
Set InvokePattern = Nothing

End Function

( ̄ー ̄)/~~ジャ
関連記事
スポンサーサイト



コメントの投稿

非公開コメント

おもちゃ箱
Count from 2010/01/14

にほんブログ村 バイクブログ ドゥカティへ


カレンダー
09 | 2019/10 | 11
- - 1 2 3 4 5
6 7 8 9 10 11 12
13 14 15 16 17 18 19
20 21 22 23 24 25 26
27 28 29 30 31 - -
最新記事
最新コメント
カテゴリ
月別アーカイブ
リンク
検索フォーム
RSSリンクの表示
ブロとも申請フォーム

この人とブロともになる

全記事表示リンク

全ての記事を表示する