FC2ブログ

インターネット接続復旧へのみちのり

最初にこたえを書いておく
嫁がスイッチングハブにループ接続させやがったため、宅内ネットワークが半死になった。
ケーブルを抜いたら完全復活した。

参考

ループ構成をやってはいけないのはなぜ?

2台のスイッチを2本のケーブルでつなぐと何が起こる?
https://ascii.jp/elem/000/000/561/561903/

●前提
H6年に新築4LDKを購入した際、様々な業者に宅内LAN工事をお願いしたが
LANって何?的な人ばかりで、仕方なく10Base-Tを自力で工事した。
新築戸建ての外壁に穴を開けたり、フレキを庭に埋めたり、かなりドキドキした。

そんなこんなで出来上がった宅内LANの現状は以下のとおり
もちろんケーブルもバージョンアップしてカテ5eとかになっている

外(光)
 ↓
パソコン部屋:無線ルーター  → 自分PC
        ↓
リビング:スイッチングHUB  → 嫁PC
      ↓ ↓ ↓ ↓
      宅内各部屋

リビングのスイッチングHUBは上流の無線ルーターにカスケードしている状況

ネットワークの黎明期には機器の選択肢も少なく
アライドテレシス・センターコム、ヤマハなどの高級品を使っていたが
今では1万円も出せば超高機能な機器が導入できるのはうれしい

●前からあった不具合
リビングのスイッチングHUBにつながるカスケードケーブルの爪が折れている
自力で直す能力はあるものの、なんとなく先送りしていた
そのケーブルが時々抜けるのである

嫁:ネットにつながらないから見てほしい
σ(゚∀゚ )オレ:ケーブルが抜けていた

そんなやり取りが何度かあり、先もネットにつながらなかったときに
嫁がHUBを見たら、抜けているケーブルがあったのでつないだらしい
それが不幸の始まり...

抜けていたケーブルはノートパソコンをつないで保守するため
片方はHUBにつなぎ、もう片方はHUBのそばに転がしてあったもの
はい!ループの出来上がりですだ(笑)

●半死に状態はネットを疑え
今回の不具合の一番の特徴は半死に状況
インターネットも、普通に表示できたかと思うと
次のページへの変遷ではタイムアウトする

Windowsで「問題の解決」を実施しても
・原因が見当たらない
・○○に不具合(DNSが無効やらなんやら、あらゆる種類のエラー)

最初はプロバイダの不具合を疑ったが、そうこうしているうちに自LANの不具合を発見
無線ルーターに直付けしている自分PCからルーターにPIGを打ってもタイムアウトする!
それでも、半死にのネットなので、ルーターの設定画面を何とか開き

状況を分析し、印刷しようとするが、プリンターはLAN直付けなので
まともに印刷できない
最後は、PCの画面をスマホで写真を撮って、ゆっくり分析

●過去の経験から

このような半死の状況、実は同じIPを設定したプリンターサーバーを同じセグメントに接続したときに起きたことがある
ARPによるブロードキャストストームだ

宅内LANを設計した時点では、すべての機器に固定IPを割り付けるものと考えていたが
無線LANの使い勝手を考えればDHCPも捨てがたい
そこで、最近の運用では、IPの最後を1-128を手動固定IP
129以上をDHCP自動割当てとして運用してきた

こうした状況から、ネットにつながっているすべての機器を確認するとともに
全部DHCPに切り替えて回った

「ループ接続か?」とも頭をよぎったが
「機械音痴の嫁がそんなことをするわけがない」と心の奥に押し込めた

●ルーターを買い替えた

朦朧とした意識のままさまよったあげく、
気が付いたσ(゚∀゚)ワタシは、クレイモア地雷を手に取っていた
25948676_p0_master1200.jpg
いや違う、Buffaloの最新無線ルーターである
163884a.jpg

「これですべてが解決する」はず

だったが、改善せず

●嫁は自分のやったことの意味がわからず
結局、リビングのHUBにループ配線を発見
嫁に「なんかやった?」と聞いても
「抜けていたから刺した」とは答えず「何もやっていない」という

それほどまでに無意識に、悪意もなくやったことなので
このことを問い詰めるのはやめにした

●最新の無線ルーターは

距離も遠くまで届き、速さマシマシなんだそうである
実は、これfまで使っていた無線ルーターは、σ(゚∀゚)ワタシがiPhoneを買って
そのスペックが生かせないことから、8年前に買い替えたもので、ちょうど更新時期ではあった

嫁や娘らが自宅にいるときは、常に無線LANでネットを利用するのだが
パソコン部屋に置いた無線ルーターからリビングまでは少し距離があり
使い勝手が悪かったようなので、これで改善が期待できる

しかし、σ(゚∀゚)ワタシのスマホは8年前のiPhoneのままなので
速さの恩恵は全くない<キッパリ


( ̄ー ̄)/~~ジャ
スポンサーサイト



Excelで特定のシートのセル範囲でOnKeyイベントを取得してみた

ExcelからIEをコントロールするVBAを書いてきたなかで
Excelの特定のセルをダブルクリックすると、そのセルの値でIEを検索する処理を作ってきた

Worksheet_BeforeDoubleClickのTargetの値を使えばそれなりの動作はする
IEの検索キーテキストにセルの値をセットして、検索ボタンを押せばいい

たとえば
顧客番号のセルをダブルクリックすれば
その顧客のトップ画面が表示される仕組みだ

このエクセルで、だいぶ業務改善がなされたのではあるが
職場には、ダブルクリックが満足にできない人がいることが問題になった
「えっ、ダブルクリックができない人がいるんデツカ?」

と、マウス操作が満足にできない事例を書き始めたのだが
それはまたこんどにしておく

●Excelでキーボード入力を検知する
論理的には
テンキーのEnterは受け付けない
Ctrl+Cは受け付けない(コピーさせない)
とかも可能と思われるが

今回のお題は、特定のセル範囲でEnterが押されたときの動作である

キーボードの入力を感知して、自分が作成したマクロを動作させる方法には2つある
1.Application.MacroOptions Macro:="作ったマクロ", ShortcutKey:="KEY文字"
2.Application.OnKey "KEY文字", "作ったマクロ"

1は、マクロオプションダイヤログで作成済マクロにキーを割り付けるもので
一度実行すればそのブックの中でだけ有効となり、この設定はブックとともに保存されるので、次回もブックを開けば有効となる。
ただし、割り付けできるキーは、コントロールとの組み合わせに限られるので、今回のお題には対応できない。

2は、起動中のExcel自身に設定されるもので
様々なキーを割り付けることができるが、1と違いブックに依存するものではないので、誤爆対策をしなければならない
ネットをOnkey VBAなどで検索すると、文法の説明は出てくるが、誤爆対策の情報が少なかったので、これを実装してみたわけだ

●OnKeyの誤爆対策
特定のブックの、特定のシートの、特定のセル範囲でのみキー検知を有効にする
おおまかなポイントは以下の通り

1.Workbook_Openで特定のブックの、特定のシートの、特定のセル範囲を指定
2.Workbook_BeforeClose OnKeyの無効化
3.Workbook_WindowDeactivate OnKeyの無効化
4.Workbook_WindowActivate OnKeyを設定すべきかを判定
5.Workbook_SheetActivate OnKeyを設定すべきかを判定
6.Workbook_SheetSelectionChange OnKeyを設定すべきかを判定
7.OnKeyを設定すべきかを判定するマクロ

これらをThisWorkBookモジュールに記載する
上記のうち1から6は、このブックにおけるイベントを感知するマクロで

1.Workbook_Openブックを開いた時
2.Workbook_BeforeClose ブックを閉じるとき
3.Workbook_WindowDeactivate ブックが非アクティブ化(ほかのブックを選択など)
4.Workbook_WindowActivate ブックがアクティブ化(対象のシートとは限らない)
 ひょっとしたらいらないかも
5.Workbook_SheetActivate シートのアクティブ化
 今回のサンプルでは、Workbook_SheetDeactivateは使っていない
 イベントの発声順序を気にする処理であれば、こうしたイベントを利用する必要もあるが
 シートの選択変更があればSheetActivateが必ず発生するので充分とみました
 なお、このイベントは、このブックの中でだけ感知します。他のブックでのシート変更は感知しません
 また、このイベントはWorkbook_Openの直後に必ず起動されるので、Openイベントを汚しません
6.Workbook_SheetSelectionChange 選択セル範囲の変更
 このブックのいずれかのシートで選択セル範囲の変更が発生した場合に感知します

7.OnKeyを設定すべきかを判定するマクロ 単なるユーザーマクロ
 Workbook_Openで標準モジュールのグローバル変数に対象となるRangeを保存しており
 このマクロでは、引数の現在シートと現在Rangeを元に、OnKey設定の是非を判断します
 なお、OnKey設定時に起動するマクロは標準モジュールに記載します

●制限
1.複数のブックで同一のKeyを割り当てての実行はできません
 OnKeyはApplicationつまりExcel内で共通に監視されるものであることから
 複数のブックから同一のキーに割り当てると衝突が発生します
2.セルの重なりに判定にIntersectを使っているので、マウスで複数のセル範囲を選択した場合
 一部でも指定範囲にあればOnKey設定します。厳密な処理をするのであればここを改良してください。

●ThisWorkBookモジュールに
Option Explicit
'------------------------------------
'特定のブックの特定のシートの特定のセル範囲でEnterが押されたことを感知して
'指定した処理を実行します
'●制限
'複数のブックで同一のKeyを割り当てての実行はできません
'OnKeyはApplicationつまりExcel内で共通に監視されるものであることから
'複数のブックから同一のキーに割り当てると衝突が発生します
'セルの重なりに判定にIntersectを使っているので、マウスで複数のセル範囲を選択した場合
'一部でも指定範囲にあればOnKey設定します。厳密な処理をするのであればここを改良してください。
'------------------------------------
Private Sub Workbook_Open()
'------------------------------------
'ブックを開いたときに対象範囲を設定
'------------------------------------
    Dim Book_Name As String
    Dim Sheet_Name As String
    Dim StartCell As String
    Dim Endcell As String
    
    Book_Name = Me.Name
    Sheet_Name = Worksheets("Menu").Range("B1").Value
    '開始セル、終了セルは、A4:B6、4:6、A:BなどRange指定として存在しうる表現である必要があります
    StartCell = Worksheets("Menu").Range("B2").Value
    Endcell = Worksheets("Menu").Range("B3").Value
    
    'gbl_Target_Rangeは標準モジュールにPublic変数として定義
    Set gbl_Target_Range = Workbooks(Book_Name).Worksheets(Sheet_Name).Range(StartCell & ":" & Endcell)
    MsgBox gbl_Target_Range.Parent.Parent.Name & "." & gbl_Target_Range.Parent.Name & "." & gbl_Target_Range.Address
    
    'ブックを開いたときのOnKey設定は、保存時に選択されていたシートがアクティブになるイベントで起動されます
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'------------------------------------
'自分ブックが閉じられたときOnKeyの解除
'------------------------------------
    Debug.Print "ブックが閉じられました"
    Application.OnKey "{Enter}"
    Application.OnKey "~"
End Sub

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
'------------------------------------
'自分ブックがアクティブ化されたときOnKeyの設定判断
'------------------------------------
    Debug.Print "ブックがアクティブされました"
    Call Check_Cell(ActiveSheet, ActiveCell)
End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
'------------------------------------
'自分ブックが非アクティブ化されたときOnKeyの解除
'------------------------------------
    Debug.Print "ブックが非アクティブされました"
    Application.OnKey "{Enter}"
    Application.OnKey "~"
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
'------------------------------------
'自分ブックがアクティブ中にシートの選択が変更されたときOnKeyの設定判断
'------------------------------------
    Debug.Print "シートの選択が変更されました"
    Call Check_Cell(Sh, ActiveCell)
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'------------------------------------
'自分ブックがアクティブ中に各シートのアクティブセルが変更されたときOnKeyの設定判断
'------------------------------------
    Debug.Print "セルの選択が変更されました"
    Call Check_Cell(Sh, Target)
End Sub

Private Sub Check_Cell(ByVal Sh As Object, ByVal Target As Range)
'------------------------------------
'OnKeyの設定判断
'------------------------------------
    '自分ブックか
    If gbl_Target_Range.Parent.Parent.Name <> Me.Name Then
        Debug.Print "ブックが違います"
        Application.OnKey "{Enter}"
        Application.OnKey "~"
    Else
        '自分シートか
        If gbl_Target_Range.Parent.Name <> Sh.Name Then
            Debug.Print "Sheetが違います"
            Application.OnKey "{Enter}"
            Application.OnKey "~"
        Else
            '指定セル範囲か
            Dim TempTarget As Range
            Set TempTarget = Application.Intersect(Target, gbl_Target_Range)
            If TempTarget Is Nothing Then
                Debug.Print "範囲外です"
                Application.OnKey "{Enter}"
                Application.OnKey "~"
            Else
                'テンキーと文字キーのEnterにイベントをセット
                Debug.Print "OnKeyが設定されました"
                '起動される"OnKey_EVT_MSG"は標準モジュールに定義
                Application.OnKey "{Enter}", "OnKey_EVT_MSG"
                Application.OnKey "~", "OnKey_EVT_MSG"
                Set TempTarget = Nothing
            End If
        End If
    End If
End Sub

●標準モジュールに
Option Explicit

'ThisWorkBookで参照する変数
Public gbl_Target_Range As Range

'ThisWorkBookで参照するSub
Sub OnKey_EVT_MSG()
    MsgBox ActiveCell.Address & "でEnterが押されました。"
End Sub

●補足
今回は対象範囲の設定に汎用性を持たせるため
Menuというシートに設定値を保存しておき
これをOpenイベントで取りに行っています

ここを改良すれば、複数のセル範囲に、様々なマクロを、様々なキーに割り付けることも可能でしょう
逆に、ユーザーにここを変更されてしまうと誤動作にもつながりますので、マクロの中に埋め込む必要もあるかもしれません

●おまけ
ThisWorkBookのWorkbook_SheetChangeイベントや、各シートのWorksheet_Changeイベントは
セルの値に変更があったときに発生するイベントです

今回はOnKeyによるEnter感知という、少々大げさな仕様になりましたが
同等のことが簡単に実現できる方法としては以下の通り


チェックしたい値を持つセルとは別のダミーセルを用意
そのシートのWorksheet_Changeイベントに実行させたいマクロを起動するよう記載

例えばA1セルに検索キーがあって、B1セルに1を入力したとして
Worksheet_Changeの引数にはTarget As Rangeがありますので
Target.AddressがB1で、Valueが1なら、A1のValueを取り出して処理する

これなら、このマクロは、このブックの、このシートの、特定のセルだけに反応しますので
誤爆は発生しにくいし、作成も簡単です
以上、みなさまの参考になれば

( ̄ー ̄)/~~ジャ

環境変数を使ってVBAの動作を外部から制御(安全に停止)してみる

非常に時間のかかるループ処理を途中で止めたくなることってありますよね
でも、エスケープやブレークキーでVBAをとめるのは、ユーザーにVBAソースを晒すことになり2次被害の心配もある
さらには、時間がかかる処理であれば、中断と再開ができなければそれまでの処理が無駄になってしまう


〇VBAの動作に中断と再開ができればすばらしい
例えば、非常に件数の多いレコードを入力して集計するプログラムがあったとする
集計作業はメモリー上の変数に確保するのはあたりまえですが
集計の中断によりこの変数をワークシートに保存できれば、再開も容易になる

流れ的には
1.前回処理による集計結果のワークシートから変数に値をセット
2.前回処理で保存された入力レコードのキーなり件数なりで入力再開レコード位置決め
3.集計ループ
4.集計結果をワークシートに保存
5.オプションとして、新規集計処理用にワークシートの初期化

上記の集計ループを抜ける条件に、入力ファイルの終了だけでなく、外部から何らかの指示があったことを検知できれば中断が可能


〇外部から何らかの指示をするには
いろいろ考えてみましたが、思い出したのが環境変数
σ(゚∀゚)ワタシはMS-DOS3.1時代のプログラマでしたので
雑誌記事のバッチ道場とかも好きでよく読んでいました

〇Windows10でもどっこい生きてる環境変数
今ではほとんど目にすることのない環境変数ですが、おためし確認ということで
メニューからコマンドプロンプトを起動し
setと入力しエンターキーを押すと環境変数が表示されます

〇環境変数を使った制御の仕様
環境変数の詳細はネットを検索してください
今回は
種類:User
変数名:ExcelCtrl
変数の値:1 2 3....なんでもいいです

エクセルVBAでループするロジックを作成
ループの最後に環境変数ExcelCtrlの値を取得、および環境変数ExcelCtrl自身を削除する処理を設定します
取得された値により動作を制御=空文字("")でなければループを抜ける

環境変数ExcelCtrlをエクセル以外から設定
今回はお手軽にVBSから設定してみます

なお、今回作成するVBAにおける環境変数の値の取得では以下の点に注意してください
指定した環境変数名が定義されていない、または定義されていても値が設定されていない場合
取得される値は空文字("")となります

VBAの処理の流れを複雑に変更するなどの場合は環境変数の値でコントロールすべきですが
ループを抜ける判断だけであれば空文字以外になったことがわかれば十分ですね

〇環境変数を追加、値設定のVBS
ExcelCtrl.VBS メモ帳に張り付けてこのファイル名で保存

Set objShell = WScript.CreateObject("WScript.Shell") 'シェルを取得
Set colEnv = objShell.Environment("User") '環境変数の種類をUserにする
colEnv.Item("ExcelCtrl") = "Exit" '環境変数名ExcelCtrlに値Exitを設定 既存なら上書き存在しなければ追加される
Set colEnv = Nothing
Set objShel = Nothing


〇環境変数を確認するVBA
Option Explicit

'---------------------------
Sub test()
Dim strENV As String

strENV = ""
Do
    DoEvents
    strENV = CHKENV("User", "ExcelCtrl")
Loop Until strENV <> ""

AppActivate Application.Caption
MsgBox strENV
End Sub

'---------------------------
Private Function CHKENV(ENVType As String, ENVName As String) As String
'環境変数の値を取得
'指定した環境変数名が定義されていない、または定義されていても値が設定されていない場合
'取得される値は空文字("")となります
Dim objWSH As Object
Set objWSH = CreateObject("WScript.Shell")

'環境変数の種類(ENVType)にはSystemやUserがありますが、通常はUserを利用します
'指定した環境変数名(ENVName)の値を取得
CHKENV = objWSH.Environment(ENVType).Item(ENVName)

'不要になった環境変数は念のため削除
If CHKENV <> "" Then
    objWSH.Environment(ENVType).Remove (ENVName)
End If

Set objWSH = Nothing
End Function


以上をVBAの標準モジュールに貼り付けtestを実行するとループが開始されます
次にExcelCtrl.VBSを実行するとExcelのループが終了しVBSで設定したExitが表示されるはずです
※重要:ループ処理の中に必ずDoEventsを入れてください。

〇おまけ
環境変数は各プログラムの起動時に取得しているため、既に起動中のプログラムには反映されません。(このVBAではCHKENV関数の中で毎回環境変数の取り直しをしています)
例えば、先のVBSの実行前にコマンドプロンプトを起動し、set ExcelCtrlで環境変数を確認すると未定義状態ですが
VBSを実行した後に別のコマンドプロンプトを起動し、set ExcelCtrlで環境変数を確認するとExitが返ってくる
でも、先に開いていたコマンドプロンプトもう一度環境変数を確認しても未定義状態のままです
動作確認でコマンドプロンプトを利用するときは注意してください


さて
どうでしょう
なんとなく「面倒な中断処理」がたった数行のプログラムで実現できたのでは?

それではみなさんまた来週
( ̄ー ̄)/~~ジャ

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

( ̄ー ̄)/~~ジャ

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

通知バーもやっつけてます

さて、前回は
VBAやVBSでWebスクレイピング(結構本気のVBS版)
http://hymandr1200st.blog.fc2.com/blog-entry-1229.html
にて、VBAに制御を残しつつAlertボックスに対応するためのVBSについて書きました

今回はこれを実際に利用したサンプルについて書いてみたいと思います

なお、一度にすべてを書ききれない気がするので、まずは準備編ということでヨロ

〇やっつけるHTML等の準備
1.デスクトップにPopUpというフォルダを作ってください
2.前回書いたIECtrlSub.VBSをここに保存
3.後述するHTMLファイル2つをここに保存
4.次回記載予定のVBAを格納するxlsmファイル(名前は適当でかまいません)をここに保存

〇HTMLの動作確認
showModalDialog.htmlをIEで起動してください
あっ、お約束ですが、これIEでしか動作しません
window.showModalDialogはIE意外では廃止されています

そのPCのセキュリティー設定にもよりますが
showModalDialog.htmlを開くとJavaScriptを含むページを処理するかの「通知バー」が表示されると思います
今回は「ブロックされているコンテンツを許可」してください

つづいて、IEに表示されている「モーダルダイアログを開く」ボタンをクリック
すると、今回のテーマであるモーダルダイアログが表示されました
この状態で親ウインドウをクリックしてもモーダルダイアログに邪魔されて前面にならないことを確認してください

では表示されているモーダルダイアログの「自分自身のウインドウを閉じる」ボタンをクリック
WEBページからのメッセージというAlertボックスにhogeと表示されたはずです
ちなみにこのhogeはモーダルダイアログからの戻り値です

動作確認のポイントをまとめますと
Webスクレイピングでの課題とされてきた次の3要素をやっつけることを目的としています
1.UI通知バーへの応答
2.window.showModalDialogによるモーダルダイアログへの応答
3.Alertボックスへの応答

ちなみに、window.showModalDialogからAlertボックスへの応答が完了するまでは一連のJavaScriptで実行されているので、VBAで「モーダルダイアログを開く」をクリックしてはいけません
今回用意するVBAでは、「モーダルダイアログを開く」を先のIECtrlSub.VBSでクリックさせ、モーダルダイアログが表示されるのを待ち構えて処理するものです
なお、今回のサンプルではモーダルダイアログへの応答後に「必ずAlertボックスが表示される」前提で作っていますが、動作が不定の場合は何等か別の対策が必要となります

〇おまけ
UIオートメーション(通知バー)については日本語の資料が少なく
また、資料があっても難解です
今回はネットに転がっていた情報をつなぎ合わせたら動いた程度なので動作不良等もありうるところはご勘弁ください
また、以下に掲載するテスト用のHTMLもネットから拾ってきたものをそのまま掲載しました
作成者のページ(URL)を失念してしまいましたので記載できていません
情報がありましたらコメント願います

※以下のリンクをダウンロードまたはコピペしてください
親HTML
showModalDialog.html
親HTML
<html lang="ja">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<title>モーダルダイアログを開くサンプル</title>
<script type="text/javascript" charset="UTF-8">
  onload = function() {
    var btn = document.getElementById("btnOpen");
    btn.onclick = function() {
      var url = "ModalDialog.html";
      var winWidth = "400px";
      var winHeight = "300px";
      var options = "dialogWidth=" + winWidth + ";dialogHeight=\
  " + winHeight + ";center=1;status=1;scroll=1;resizable=1;\
  minimize=0;maximize=0;";
     
      // ボタンをグレーアウトする
      btn.disabled = true;
      var returnValue = showModalDialog(url, window, options);
      // 戻り値をアラート
      alert(returnValue);
    }
  }
</script>
</head>
<body>
<h1>モーダルダイアログを開くサンプル</h1>
<input type="button" id="btnOpen" value="モーダルダイアログを開く">
</body>
</html>


子HTML
ModalDialog.html
子HTML


<html lang="ja">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<title>モーダルダイアログ</title>
<script type="text/javascript" charset="UTF-8">
  onload = function() {
    // 自分自身のウインドウを閉じる
    document.getElementById("btnClose").onclick = CloseDialog;
    onunload = CloseDialog;
   
    function CloseDialog() {
      // 親ウインドウを取得する(IE用)
      if(!opener) {
        opener = dialogArguments;
      }
     
      // 親ウインドウのボタンのグレーアウトを解除する
      opener.document.getElementById("btnOpen").disabled = false;
      returnValue = "hoge";
      close();
    }
  }
</script>
</head>
<body>
<h1>モーダルダイアログ</h1>
<input type="button" id="btnClose" value="自分自身のウインドウを閉じる">
</body>
</html>
続きはまた次回に
( ̄ー ̄)/~~ジャ
おもちゃ箱
Count from 2010/01/14:
現在の閲覧者数:
にほんブログ村 バイクブログ ドゥカティへ


カレンダー
05 | 2020/06 | 07
- 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 - - - -
最新記事
最新コメント
カテゴリ
月別アーカイブ
リンク
検索フォーム
RSSリンクの表示
ブロとも申請フォーム

この人とブロともになる

全記事表示リンク

全ての記事を表示する