イベントフック

Option Explicit

' 指定したIE上のイベントをフックし、
' VBScriptで記述した処理に動的に書き換える。
' フックスクリプトで使用可能なオブジェクト、
' 関数は以下のとおり。
'   window     ：windowオブジェクト
'   document   ：documentオブジェクト
'   getEvent   ：eventオブジェクト取得関数
'                (eventが予約語のためgetEventとした)
'   callOrgFunc：フックしたイベントに設定されている元処理を呼び出す関数。
'                (既存処理がある場合は自動で出力されるため、手動での記述は不要)
'   getElement ：ユニークIDを指定して画面上の任意の要素オブジェクトを取得する関数。
'                (クリップボード経由での出力となるため、手動での記述は不要)

' 取得、フック対象の要素の種類を増やす場合や、
' フック対象イベントの追加/変更を行う場合は
' DataInit(716行目)を修正すること。

' 要素ダブルクリック時に枠を表示する場合true
Const BORDER_FOCUS = true

' 最小画面サイズ
Const FORM_HEIGHT_MIN = 400
Const FORM_WIDTH_MIN  = 600

' 画面生成用HTMLの定数定義
Const ID_TXT_TITLE = "titleText"
Const ID_TXT_URL   = "urlText"
Const ID_CMB_ELM   = "elmCombo"
Const ID_LST_ELM   = "elmList"
Const ID_TXT_SCRIPT= "scriptText"
Const ID_BTN_GET   = "getButton"
Const ID_BTN_HOOK  = "hookButton"
Const ID_BTN_APPLY = "applyButton"
Const ID_BTN_EXIT  = "exitButton"
Const TAG_ID_NAME   = 0
Const TAG_DISP_NAME = 1
Const TAG_NAME      = 2
Const TAG_ADD_INFO  = 3
Const TAG_LIST_INFO = 4
Const BORDER_ID = "hookfunc_border_div"
Const CODE_INDENT = "  "

' 変数定義
Dim formIe, elmMap, hookIe
Dim tagList, eventList, procList

' フックスクリプト参照用オブジェクト
Dim window, document

Main
WScript.Quit

Sub Main
    Dim ret, url
    
    ' 表示タグ情報のデータを初期化
    Set tagList   = CreateObject("Scripting.Dictionary")
    Set eventList = CreateObject("Scripting.Dictionary")
    Set procList  = CreateObject("Scripting.Dictionary")
    DataInit tagList, eventList

ret = GetSelectedIEObject("フック対象のページを表示しているIEを選択してください。", hookIe)
    If (ret <> RETURN_OK) Then
        WScript.Quit
    End If
    
    ' IEオブジェクトを作成
    Set elmMap = CreateObject("Scripting.Dictionary")
    Set formIe = CreateForm(elmMap)
    
    ' フック対象IEを使ってフォームの表示データを初期化
    SetInitView elmMap, hookIe, tagList

' スクリプト参照用のオブジェクトを設定
    setReffObject(hookIe)

' フック対象IEのURLを取得
    url = hookIe.LocationURL

' IEが非表示になるまで待機
    On Error Resume Next

Do While(formIe.Visible)
        WScript.Sleep 1000

If (url <> hookIe.LocationURL) Then
            msgbox "フック対象のIEの表次ページが変更されました。" & vbCrLf & "フック処理を終了します。"
            Exit Do
        End If

' hookIe、formIeにアクセスできなくなった場合は終了
        If (Err.Number = 462) Then    '発生エラー 462:リモート サーバーがないか、使用できる状態ではありません。
            Exit Sub
        End If
        
        'エラー発生時はエラーメッセージを表示
        If (Err.Number <> 0) Then
            msgbox err.number & vbcrlf & err.Description
            err.clear
        end if
        
    Loop
    
    formIe.Quit
    
End Sub

' フォームを作成
Function CreateForm(elmMap)
    Dim ie
    Dim headerTable, titleTr, urlTr, titleTd, urlTd, titleText, urlText
    
    ' IEで画面を作る
    Set ie = WScript.CreateObject("InternetExplorer.Application")
    ie.Navigate "about:blank"
    
    ' 起動終了まで待機
    Do While(ie.Busy)
        WScript.Sleep 50
    Loop

' オブジェクトで作ると面倒なのでhtmlで画面を作成
    ie.Document.body.innerHtml = GetFormHtml()

' オブジェクト情報をマップに格納
    With ie.Document
        elmMap.Add ID_TXT_TITLE,  .getElementById(ID_TXT_TITLE)
        elmMap.Add ID_TXT_URL,    .getElementById(ID_TXT_URL)
        elmMap.Add ID_CMB_ELM,    .getElementById(ID_CMB_ELM)
        elmMap.Add ID_LST_ELM,    .getElementById(ID_LST_ELM)
        elmMap.Add ID_BTN_GET,    .getElementById(ID_BTN_GET)
        elmMap.Add ID_BTN_HOOK,   .getElementById(ID_BTN_HOOK)
        elmMap.Add ID_BTN_APPLY,  .getElementById(ID_BTN_APPLY)
        elmMap.Add ID_BTN_EXIT,   .getElementById(ID_BTN_EXIT)
        elmMap.Add ID_TXT_SCRIPT, .getElementById(ID_TXT_SCRIPT)
    End With

' イベント発生時の処理をイベント関数に登録
    Set elmMap.Item(ID_BTN_GET).onclick    = GetRef("EventHandle")
    Set elmMap.Item(ID_BTN_HOOK).onclick   = GetRef("EventHandle")
    Set elmMap.Item(ID_BTN_APPLY).onclick  = GetRef("EventHandle")
    Set elmMap.Item(ID_BTN_EXIT).onclick   = GetRef("EventHandle")
    Set elmMap.Item(ID_CMB_ELM).onchange   = GetRef("EventHandle")
    Set elmMap.Item(ID_LST_ELM).onchange   = GetRef("EventHandle")
    Set elmMap.Item(ID_LST_ELM).ondblclick = GetRef("EventHandle")
    Set ie.Document.body.onresize = GetRef("EventHandle")
    
    ' 画面表示を整える
    With ie
        .AddressBar = false
        .MenuBar    = false
        .Resizable  = true
        .StatusBar  = false
        .ToolBar    = false
        .Visible    = true
        .height     = FORM_HEIGHT_MIN
        .Document.title = "イベントフック"
    End With

' アクティブ化
    activateIe ie

Set CreateForm = ie

End Function

' イベントを処理する
Sub EventHandle
    Dim elm
    Dim borderBefore, borderAfter, tagInfo

' フォーム完成前に呼ばれた場合は無視
    If (formIe = Empty) Then
        Exit Sub
    End If

' bodyイベントの場合はevent.srcElementがない
    If (formIe.Document.parentWindow.event.srcElement is Nothing) Then
        Call OnFormResize
        Exit Sub
    End If

Select Case (formIe.Document.parentWindow.event.srcElement.id)
    
    ' 取得ボタンクリック時の処理
    Case ID_BTN_GET
        Call OnGetClick
    
    ' フックボタンクリック時の処理
    Case ID_BTN_HOOK
        Call OnHookClick
    
    ' 適用ボタンクリック時の処理
    Case ID_BTN_APPLY
        Call OnApplyClick
        
    ' 終了ボタンクリック時の処理
    Case ID_BTN_EXIT
        formIe.Visible = False
        
    ' コンボボックス選択時の処理
    Case ID_CMB_ELM
        Call OnComboBoxSelected
    
    ' リストボックスのイベント処理
    Case ID_LST_ELM
        Call OnListBoxEvent(formIe.Document.parentWindow.event.type)
    
    End Select
End Sub

' フォームの表示を初期化
Sub SetInitView (elmMap, ie, tagInfo)
    Dim opt
    elmMap.Item(ID_TXT_TITLE).Value = ie.Document.title
    elmMap.Item(ID_TXT_URL).Value   = ie.LocationURL
    RefreshCombo elmMap.Item(ID_CMB_ELM), hookIe, tagList
    Set opt = elmMap.Item(ID_CMB_ELM).options(elmMap.Item(ID_CMB_ELM).selectedIndex)
    RefreshList elmMap.Item(ID_LST_ELM), hookIe, tagList.Item(opt.value)
End Sub

' フォームのサイズが変更されたときの処理
Sub OnFormResize

' 高さが最小値を下回った場合は最小値に設定
    If (formIe.Height < FORM_HEIGHT_MIN) Then
        formIe.Height = FORM_HEIGHT_MIN
    End If
    
    ' 幅が最小値を下回った場合は最小値に設定
    If (formIe.Width < FORM_WIDTH_MIN) Then
        formIe.Width = FORM_WIDTH_MIN
    End If
    
    ' リストボックス、テキストエリアの高さを変更
    elmMap.Item(ID_LST_ELM).style.height = (formIe.Height - 210)
    elmMap.Item(ID_TXT_SCRIPT).style.height = (formIe.Height - 190)
    
End Sub

' 取得ボタンクリック時の処理
Sub OnGetClick
    Dim tagId, uniqueId, code
    
    ' タグ情報の識別名、ユニークIDを取得
    tagId = elmMap.Item(ID_CMB_ELM).name
    uniqueId = elmMap.Item(ID_LST_ELM).options(elmMap.Item(ID_LST_ELM).selectedIndex).value
    
    ' クリップボードにコピー
    code = "getElement(""" & tagId & """, """ & uniqueId & """)"
    formIe.Document.parentWindow.clipboardData.setData "text", code
    
    msgbox "オブジェクト取得用コードをクリップボードにコピーしました。" & vbCrLf & "オブジェクト取得用コード：" & vbCrLf & code
    
End Sub

' フックボタンクリック時の処理
Sub OnHookClick
    Dim tagId, elmId, eventName, procName, elm, orgFunc, orgCall, proc, code, tagInfo

' 要素に関連付けられているイベントの一覧があるか確認
    tagId = elmMap.Item(ID_CMB_ELM).name
    If ( Not eventList.Exists(tagId) ) Then
        msgbox tagList.Item(tagId)(TAG_DISP_NAME) & "に関するイベントが定義されていません。"
        Exit Sub
    End If

' フック対象のイベント名を選択
    eventName = SelectList(eventList.Item(tagId), TYPE_STRING, "フックするイベントを選択してください。")
    If (eventName = STRING_CANCEL) Then
        Exit Sub
    End If
    
    ' 既に同じuniqueIdとイベント名で登録済みかどうか確認
    elmId = elmMap.Item(ID_LST_ELM).options(elmMap.Item(ID_LST_ELM).selectedIndex).value
    For Each proc in procList.Items
        If ((proc.uniqueId = elmId) And (proc.eventName = eventName)) Then
            msgbox "既に同じイベントが" & proc.name & "として登録済みです。"
            Exit Sub
        End If
    Next
    
    'フックプロシージャの名前を決定
    procName = InputBox("Function xxxx_" & eventName & vbCrLf & "プロシージャ名に設定する値(xxxx)を入力してください。" & vbCrLf & "デフォルト値：" & elmId, elmId)
    procName = Replace(procName, " ", vbNullString)
    If (procName = vbNullString) Then
        procName = elmId
    End If
    procName = procName & "_" & eventName
    
    ' 既に同名のプロシージャが存在した場合は処理を中断
    If (procList.Exists(procName)) Then
        msgbox "既に同名のプロシージャ " & procName & " が登録されています。"
        Exit Sub
    End If
    
    ' フック前の関数リファレンスを取得
    tagInfo = tagList.Item(tagId)
    Set elm = GetElementByTagInfo(hookIe, tagInfo, elmId)
    If (elm Is Nothing) Then
        msgbox "フック対象の要素が見つかりませんでした。"
        Exit Sub
    End If
    If (Eval("IsNull(elm." & eventName & ")")) Then
        Set orgFunc = Nothing
    Else
        Execute "Set orgFunc = elm." & eventName
    End If

' 初期コードを設定
    code = "Function " & procName & vbCrLf
    If (Not orgFunc Is Nothing) Then
        code = code & CODE_INDENT & "callOrgFunc(""" & procName & """)" & vbCrLf
    End If
    code = code & "End Function"

Set proc = Nothing
    Set proc = New ProcInfo
    proc.setParam elmId, tagInfo, eventName, procName, orgFunc
    procList.Add procName, proc

' テキストエリアにプロシージャを追加
    elmMap.Item(ID_TXT_SCRIPT).value = elmMap.Item(ID_TXT_SCRIPT).value & vbCrLf & code & vbCrLf

End Sub

' 適用ボタンクリック時の処理
Sub OnApplyClick
    Dim code, proc, elm
    
    ' 記述コードを反映
    code = elmMap.Item(ID_TXT_SCRIPT).value
    ExecuteGlobal code

' フック関数を記述プロシージャで置き換え
    For Each proc in procList.Items
        Set elm = GetElementByTagInfo(hookIe, proc.tagInfo, proc.uniqueId)
        If (elm Is Nothing) Then
            msgbox "フック対象の要素 " & proc.uniqueId & " が見つかりませんでした。"
        End If
        Execute "Set elm." & proc.eventName & " = GetRef(""" & proc.name & """)"
    Next

msgbox "記述されたコードで処理を上書きしました。"
    
End Sub

' リストボックスに関するイベント処理
Sub OnListBoxEvent(eventType)
    Dim borderBefore, borderAfter, tagInfo

borderBefore = elmMap.Item(ID_LST_ELM).name
    borderAfter  = elmMap.Item(ID_LST_ELM).options(elmMap.Item(ID_LST_ELM).selectedIndex).value
    tagInfo      = tagList.Item(elmMap.Item(ID_CMB_ELM).options(elmMap.Item(ID_CMB_ELM).selectedIndex).value)

Select Case eventType

' リストボックスの選択が変更されたときの処理
    Case "change"
        If ((borderBefore <> vbNullString) And (borderBefore <> borderAfter))Then
            ShowBorder borderBefore, hookIe, tagInfo, false
            elmMap.Item(ID_LST_ELM).name = vbNullString
        End If
    
    ' リストボックスがダブルクリックされたときの処理
    Case "dblclick"
        If (borderBefore = borderAfter) Then
            ShowBorder borderBefore, hookIe, tagInfo, false
            elmMap.Item(ID_LST_ELM).name = vbNullString
        Else
            ShowBorder borderAfter, hookIe, tagInfo, true
            elmMap.Item(ID_LST_ELM).name = borderAfter
        End If
    End Select
    
End Sub

' コンボボックス選択時の処理
Sub OnComboBoxSelected
    Dim borderId, tagIdBefore, tagIdAfter
    
    borderId    = elmMap.Item(ID_LST_ELM).name
    tagIdBefore = elmMap.Item(ID_CMB_ELM).name
    tagIdAfter  = elmMap.Item(ID_CMB_ELM).options(elmMap.Item(ID_CMB_ELM).selectedIndex).value

' 枠が表示されている場合は非表示にする
    If ((borderId <> vbNullString) And (tagIdBefore <> vbNullString)) Then
        ShowBorder borderId, hookIe, tagList.Item(tagIdBefore), false
        elmMap.Item(ID_LST_ELM).name = vbNullString
    End If
    
    ' リストボックスの表示を更新する
    RefreshList elmMap.Item(ID_LST_ELM), hookIe, tagList.Item(tagIdAfter)
    elmMap.Item(ID_CMB_ELM).name = tagIdAfter

End Sub

' コンボボックスの値を更新する
Sub RefreshCombo(combo, ie, tagList)
    Dim opt, tagInfo, isFirst

' 設定されているoptionを削除
    For Each opt in combo.options
        opt.removeNode true
    Next

isFirst = true
    ' 登録タグが存在すればコンボボックスに表示
    For Each tagInfo in tagList.Items
        if ( 0 < GetSize(GetElementByTagInfo(ie, tagInfo, vbNullString)) ) Then
        
            Set opt = combo.ownerDocument.createElement ("option")
            combo.add opt
            opt.innerText = tagInfo(TAG_DISP_NAME)
            opt.value = tagInfo(TAG_ID_NAME)
            
            ' 最初の値は選択されるのでコンボボックスのnameに格納
            If (isFirst) Then
                isFirst = false
                combo.name = tagInfo(TAG_ID_NAME)
            End If
            
        End If
    Next
    
End Sub

' リストボックスの値を更新する
Sub RefreshList(listBox, ie, tagInfo)
    Dim elm, opt
    
    ' 設定されているoptionを削除
    For Each opt in listBox.options
        opt.removeNode true
    Next

' リストボックスに値を追加
    For Each elm in GetElementByTagInfo(ie, tagInfo, vbNullString)
        Set opt = listBox.ownerDocument.createElement ("option")
        listBox.add opt
        opt.innerText = Eval(tagInfo(TAG_LIST_INFO))
        opt.value = elm.uniqueID
    Next

End Sub

' フックスクリプト参照用オブジェクトの設定
Sub setReffObject(ie)
    Set document = ie.Document
    Set window   = ie.Document.parentWindow
End Sub

' イベントオブジェクトの取得(フックスクリプトからの呼び出し用)
Function getEvent()
    Set getEvent = hookIe.Document.parentWindow.event
End Function

' オリジナル関数のコール(フックスクリプトからの呼び出し用)
Sub callOrgFunc(procName)
    procList.Item(procName).callOrgFunc
End Sub

' 要素を取得(フックスクリプトからの呼び出し用)
Function getElement(tagId, uniqueId)
    Set getElement = GetElementByTagInfo(hookIe, tagList.Item(tagId), uniqueId)
End Function

' 選択要素の枠を表示する
Sub ShowBorder(id, ie, tagInfo, isVisible)
    Dim elm, div

If (isVisible) Then

' 指定された要素を取得
        Set elm = GetElementByTagInfo(ie, tagInfo, id)
        If (elm Is Nothing) Then
            msgbox "指定された要素が存在しないため、枠表示処理に失敗しました。"
            Exit Sub
        End If
        
        ' 枠を表示するdiv要素を生成
        Set div = ie.Document.createElement ("div")
        div.id = BORDER_ID
        div.style.borderStyle = "solid"
        div.style.borderWidth = "3px"
        div.style.borderColor = "blue"
        elm.insertAdjacentElement "afterEnd", div
        div.insertBefore elm

' 定義値によってフォーカスを設定する
        If (BORDER_FOCUS) Then
            elm.focus
        End If

Else
        ' 枠を表示するdiv要素を取得
        Set div = ie.Document.getElementById(BORDER_ID)
        If (div Is Nothing) Then
            Exit Sub
        End If
        
        ' divを削除
        For Each elm in (ie.Document.getElementsByTagName(tagInfo(TAG_NAME)))
            If (id = elm.uniqueID) Then
                div.removeNode false
                Exit For
            End If
        Next
        
    End If
    
End Sub

' 指定されたタグの要素(のコレクション/配列)を返す
Function GetElementByTagInfo(ie, tagInfo, uniqueId)

Dim dict, elm
    Set dict = CreateObject("Scripting.Dictionary")

' 検索条件に一致するものが無ければNothingを返す
    Set GetElementByTagInfo = Nothing

' uniqueIdが指定されていない場合はtagInfoで指定された要素のコレクションを返す
    If (uniqueId = vbNullString) Then
    
        ' 検索用の付加情報がない場合はタグ名の一致のみを判定する
        If (LenB(tagInfo(TAG_ADD_INFO)) = 0) Then
            Set GetElementByTagInfo = ie.Document.getElementsByTagName(tagInfo(TAG_NAME))
            
        ' 付加情報がある場合は付加情報に一致した要素を取得
        Else
            For Each elm in ie.Document.getElementsByTagName(tagInfo(TAG_NAME))
                If (Eval(tagInfo(TAG_ADD_INFO))) Then
                    dict.Add elm.uniqueId, elm
                End If
            Next
            GetElementByTagInfo = dict.Items
        End If
        
    ' uniqueIdが指定されている場合は指定された要素のみを返す
    Else
        ' 付加情報に関わらずタグ名で絞ってuniqueIdが一致する要素を返す
        For Each elm in ie.Document.getElementsByTagName(tagInfo(TAG_NAME))
            If (elm.uniqueId = uniqueId) Then
                Set GetElementByTagInfo = elm
                Exit For
            End If
        Next
    End If

End Function

' コレクション、配列の要素数を返す
Function GetSize(list)
    
    If (IsObject(list)) Then
        GetSize = list.length
    Else
        GetSize = UBound(list) - LBound(list) + 1
    End If

End Function

' フォームのHTMLを返す
Function GetFormHtml()
    GetFormHtml    = _
    "<table border=""0"" style=""width:100%; height:50px; font-size:x-small;"">" & _
    " <tr align=""center"">" & _
    "  <td width=""35%"" align=""right"">タイトル：</td>" & _
    "  <td width=""65%"" align=""left"">" & _
    "   <input readonly type=""text"" size=""50"" value="""" id=""" & ID_TXT_TITLE & """></input>" & _
    "  </td>" & _
    " </tr>" & _
    " <tr>" & _
    "  <td width=""35%"" align=""right"">URL：</td>" & _
    "  <td width=""65%"" align=""left"">" & _
    "   <input readonly type=""text"" size=""50"" value="""" id=""" & ID_TXT_URL & """></input>" & _
    "  </td>" & _
    " </tr>" & _
    "</table>" & _
    "<hr>" & _
    "<table border=""0"" width=""100%"">" & _
    "  <tr>" & _
    "  <td width=""30%"">" & _
    "   <span style=""text-align:center; width:90%; height:10px; font-size:x-small;"">" & _
    "    要素の選択" & _
    "   </span>" & _
    "   <select align=""center"" name="""" size=""1"" style=""width:90%;"" id=""" & ID_CMB_ELM & """></select>" & _
    "   <br />" & _
    "   <select align=""center"" name="""" size=""2"" style=""width:90%; height:170px;"" id=""" & ID_LST_ELM & """></select>" & _
    "   <div align=""right"" width=""90%"" style=""padding-top:5px;"">" & _
    "    <button id=""" & ID_BTN_GET & """>取得</button>" & _
    "    &nbsp;" & _
    "    <button id=""" & ID_BTN_HOOK & """>フック</button>" & _
    "   </div>" & _
    "  </td>" & _
    "  <td width=""70%"">" & _
    "   <span style=""text-align:left; padding-left:5px; height:10px; font-size:x-small;"">" & _
    "    フック関数の内容：" & _
    "   </span>" & _
    "   <div align=""center"" >" & _
    "    <textarea cols=""1"" rows=""2"" style=""width:100%; height:190px;"" id=""" & ID_TXT_SCRIPT & """></textarea>" & _
    "   </div>" & _
    "   <div align=""right"" width=""90%"" style=""padding-top:5px;"">" & _
    "   <button id=""" & ID_BTN_APPLY & """>適用</button>" & _
    "   &nbsp;" & _
    "   <button id=""" & ID_BTN_EXIT & """>終了</button>" & _
    "   </div>" & _
    "  </td>" & _
    " </tr>" & _
    "</table>"
End Function

' IEを可能な限りアクティブ化する
Sub activateIe(ie)
    Dim shell
    Set shell = CreateObject("WScript.Shell")
    shell.AppActivate ie.LocationURL
    shell.AppActivate ie.Document.title
    ie.document.focus
    ie.document.parentWindow.focus
End Sub

' プロシージャの情報を格納するクラス
Class ProcInfo
    Private hookedId, hookedEvent, procName, procOrgFunc, hookedTagInfo
    
    Private Sub Class_Initialize()
        hookedId      = vbNullString
        hookedEvent   = vbNullString
        procName      = vbNullString
        Set procOrgFunc   = Nothing
        Set hookedTagInfo = Nothing
    End Sub
    
    Public Sub setParam(uniqueIdVal, tagInfoVal, eventNameVal, nameVal, orgFuncVal)
        uniqueId  = uniqueIdVal
        tagInfo   = tagInfoVal
        eventName = eventNameVal
        name      = nameVal
        orgFunc   = orgFuncVal
    End Sub
    
    Public Property Let uniqueId(val)
        hookedId = val
    End Property
    
    Public Property Get uniqueId
        uniqueId = hookedId
    End Property
    
    Public Property Let eventName(val)
        hookedEvent = val
    End Property
    
    Public Property Get eventName
        eventName = hookedEvent
    End Property
    
    Public Property Let name(val)
        procName = replace(replace(val, " ", vbNullString), vbTab, vbNullString)
    End Property
    
    Public Property Get name
        name = procName
    End Property
    
    Public Property Let orgFunc(val)
        Set procOrgFunc = val
    End Property
    
    Public Property Get orgFunc
        Set orgFunc = procOrgFunc
    End Property

Public Property Let tagInfo(val)
        hookedTagInfo = val
    End Property
    
    Public Property Get tagInfo
        tagInfo = hookedTagInfo
    End Property

Public Sub callOrgFunc()
        procOrgFunc
    End Sub

End Class

' データの初期化
Sub DataInit(tagList, eventList)
   ' 表示するタグ情報の登録
   '  <識別名>                ：タグ情報が一意に指定する名前。
   '  <タグ表示名>            ：画面のコンボボックスに表示されるタグ表示名。
   '  <タグ名>                ：htmlに設定されるタグ名。
   '  <付加情報>              ：タグ情報が<タグ名>だけで一意とならない場合に指定。
   '                            要素を表すオブジェクトを"elm"とした場合の条件式を記載。
   '                            <タグ名>だけで一意となる場合は空文字を設定する。
   '  <リストボックス表示情報>：リストボックスに表示する情報を指定。
   '                            要素を表すオブジェクトを"elm"とした場合の表示を記載。
   'tagList.Add <識別名>,         Array(<識別名>,         <タグ表示名>,     <タグ名>, <付加情報>,              <リストボックス表示情報>)
    tagList.Add "body",           Array("body",           "body",           "body",   vbNullString,            "Left(elm.innerText, 25)")
    tagList.Add "button",         Array("button",         "button",         "button", vbNullString,            "Left(elm.innerText, 25)")
    tagList.Add "a",              Array("a",              "a",              "a",      vbNullString,            "Left(elm.innerText & ""("" & elm.href & "")"", 25)")
    tagList.Add "img",            Array("img",            "img",            "img",    vbNullString,            "Left(elm.alt, 25)")
    tagList.Add "select",         Array("select",         "select",         "select", vbNullString,            "Left(elm.innerText, 25)")
    tagList.Add "input_button",   Array("input_button",   "input-button",   "input",  "elm.type=""button""" ,  "Left(elm.value, 25)")
    tagList.Add "input_checkbox", Array("input_checkbox", "input-checkbox", "input",  "elm.type=""checkbox""", "Left(elm.value, 25)")
    tagList.Add "input_file",     Array("input_file",     "input-file",     "input",  "elm.type=""file""",     "Left(elm.name, 25)")
    tagList.Add "input_image",    Array("input_image",    "input-image",    "input",  "elm.type=""image""",    "Left(elm.alt, 25)")
    tagList.Add "input_password", Array("input_password", "input-password", "input",  "elm.type=""password""", "Left(elm.name, 25)")
    tagList.Add "input_radio",    Array("input_radio",    "input-radio",    "input",  "elm.type=""radio""",    "Left(elm.value, 25)")
    tagList.Add "input_reset",    Array("input_reset",    "input-reset",    "input",  "elm.type=""reset""",    "Left(elm.value, 25)")
    tagList.Add "input_submit",   Array("input_submit",   "input-submit",   "input",  "elm.type=""submit""",   "Left(elm.value, 25)")
    tagList.Add "input_text",     Array("input_text",     "input-text",     "input",  "elm.type=""text""",     "Left(elm.value, 25)")

' タグに対応するイベント情報の登録
   '  <識別名>    ：タグ情報の識別名と一致させること。
   '  <イベント名>：タグに関連するイベント名。
   'eventList.Add <識別名>,         Array(<イベント名1>, <イベント名2>, ...)
    eventList.Add "body",           Array("onclick", "ondblclick", "onmousemove", "onresize")
    eventList.Add "button",         Array("onclick", "onmousedown", "onmouseup")
    eventList.Add "a",              Array("onclick", "onmousedown", "onmouseup")
    eventList.Add "img",            Array("onclick", "ondblclick", "onmousedown", "onmouseup")
    eventList.Add "select",         Array("onchange", "onclick", "onmousedown", "onmouseup")
    eventList.Add "input_button",   Array("onclick", "onmousedown", "onmouseup")
    eventList.Add "input_checkbox", Array("onclick", "onmousedown", "onmouseup")
    eventList.Add "input_submit",   Array("onclick", "onmousedown", "onmouseup")

eventList.Add "input_text",   Array("onchange","onload")

End Sub

'###########################################################
'               選択されたIEオブジェクトを取得
' 関数
'    GetSelectedIEObject(Caption As String, obj As Object)
'
' 引数
'     Caption：選択ダイアログに表示するキャプション
'         obj：選択されたIEオブジェクトが格納されるオブジェクト
'
' 戻り値
'    選択状態を戻り値として返す。値は以下の通り。
'        RETURN_OK：正常に取得
'     RETURN_NO_IE：IEが存在しない
'    RETURN_CANCEL：IE選択をキャンセル
'
' 制限事項
'    SelectList、GetPropertyValと同じ

Const RETURN_OK     = 0
Const RETURN_NO_IE  = 1
Const RETURN_CANCEL = 2

Function GetSelectedIEObject(Caption, obj)

Dim ObjShell, ObjDict, ObjWnd, myList, index, SelectIndex

Set ObjShell=CreateObject("Shell.Application")
    Set ObjDict = CreateObject("Scripting.Dictionary")

myList = vbNullString
    index = 0

' IEオブジェクト一覧をカンマ区切りで取得
    For Each ObjWnd In ObjShell.Windows
        If (typename(ObjWnd.Document) = "HTMLDocument") Then
            myList = myList & GetPropertyVal(ObjWnd.Document, "Title", "NoTitle") & "(" & ObjWnd.locationURL & ")○"
            objDict.Add index, ObjWnd
            index = index + 1
        End If
    Next

' IEオブジェクトがある場合は不要なカンマを削除、無い場合は終了
    If (right(myList,1) = "○") Then
        myList = left(mylist, len(mylist)-1)
    Else
        GetSelectedIEObject = RETURN_NO_IE
        Exit Function
    End If

' 捜査対象のIEを選択
    SelectIndex = SelectList(split(myList,"○"), TYPE_INDEX, Caption)

' IEオブジェクトを取得、キャンセルされた場合は中断する
    If (SelectIndex = -1) Then
        GetSelectedIEObject = RETURN_CANCEL
        Exit Function
    Else
        GetSelectedIEObject = RETURN_OK
        Set obj = objDict.Item(CInt(SelectIndex))
    End If

End Function
'###########################################################

'###########################################################

'            ドロップダウンリストで項目を選択
' 関数名
'    SelectList
'
' 引数
'    ItemList：配列形式のVariant型
'              ドロップダウンリストに設定する項目を指定
'    Type    ：戻り値の型
'              TYPE_INDEX → 数値型のインデックス(0-origine)で返す
'                            キャンセル時は-1を返す
'              TYPE_STRING → 選択された項目の文字列を返す
'                             キャンセル時は"Cancel"を返す
'    Caption ：ダイアログに表示させる文字
'
' 戻り値
'    第2引数Typeに応じて変化
'    詳細は引数の説明を参照
'
' 制限事項
'    IE右上の×ボタンから画面を閉じた場合、エラーが発生
'

Dim RetVal
Dim ObjListIE
Const TYPE_INDEX    = 0
Const TYPE_STRING   = 1
Const STRING_CANCEL = "Cancel"
Const SELECT_WIDTH  = "300px"     ' (IE_WIDTH-50)程度
Const SELECT_MARGINBOTTOM = "10px"
Const IE_HEIGHT     = 170
Const IE_WIDTH      = 360
Const IE_LEFT       = 300
Const IE_TOP        = 300

Function SelectList(ItemList, RetType, Caption)

Dim ObjSelect, ObjLF, ObjButton1, ObjButton2, ObjOption, item, index
    
    ' キャンセル時の戻り値を設定
    RetVal = STRING_CANCEL
    
    ' IEオブジェクトを取得
    Set ObjListIE = WScript.CreateObject("InternetExplorer.Application")
    ObjListIE.Navigate "about:blank"
    
    ' 起動終了まで待機
    Do While(ObjListIE.Busy)
        WScript.Sleep 50
    Loop

' IEオブジェクトにテキストを追加
    ObjListIE.Document.Body.insertAdjacentText "afterBegin", Caption
    
    ' SELECTタグを作成
    Set ObjSelect = ObjListIE.Document.createElement ("select")
    ObjSelect.style.width = SELECT_WIDTH
    ObjSelect.style.marginBottom = SELECT_MARGINBOTTOM
    ObjListIE.Document.Body.insertBefore(ObjSelect)
    
    ' SELECTタグにOPTIONを追加
    index = 0

For Each item In ItemList
        Set ObjOption = ObjListIE.Document.createElement("OPTION")
        ObjSelect.Options.Add ObjOption
        ObjOption.text = item
        ObjOption.Value = item
    Next
    
    ' SELECTタグに改行を追加
    Set ObjLF = ObjListIE.Document.createElement("BR")
    ObjListIE.Document.Body.insertBefore(ObjLF)
    
    ' Cancelボタンを追加
    Set ObjButton1 = ObjListIE.Document.createElement("button")
    ObjButton1.Value = "CANCEL"
    ObjButton1.style.styleFloat = "right"
    ObjListIE.Document.Body.insertBefore(ObjButton1)
    Set ObjButton1.onclick = GetRef("Click_Cancel")
    
    ' OKボタンを追加
    Set ObjButton2 = ObjListIE.Document.createElement("button")
    ObjButton2.Value = "OK"
    ObjButton2.style.styleFloat = "right"
    ObjListIE.Document.Body.insertBefore(ObjButton2)
    Set ObjButton2.onclick = GetRef("Click_OK")

' IEオブジェクトのステータスを設定
    With ObjListIE
        .height     = IE_HEIGHT
        .width      = IE_WIDTH
        .Left       = IE_LEFT
        .Top        = IE_TOP
        .AddressBar = false
        .MenuBar    = false
        .Resizable  = false
        .StatusBar  = false
        .ToolBar    = false
        .Visible    = true
    End With
    
    ObjListIE.Document.title = "ドロップダウン選択"

Do While(ObjListIE.Busy)
        WScript.Sleep 100
    Loop

' アクティブ化
    CreateObject("WScript.Shell").AppActivate "about:blank"
    CreateObject("WScript.Shell").AppActivate ObjListIE.Document.title
    ObjListIE.document.focus
    ObjListIE.document.parentWindow.focus

' ボタン押下まで待機
    Do While (ObjListIE.Visible)
        WScript.Sleep 100
    Loop

' OKボタンが押された場合は選択項目を返す
    If (RetVal = "OK") Then
        If (RetType = TYPE_INDEX) Then
            RetVal = ObjSelect.selectedIndex
        Else
            RetVal = ObjSelect.Value
        End If
    Else
        If (RetType = TYPE_INDEX) Then
            RetVal = -1
        Else
            RetVal = STRING_CANCEL
        End If
    End If

' IEオブジェクトを解放
    ObjListIE.Quit
    
    SelectList = RetVal

End Function

' OKボタン押下時
Function Click_OK
    RetVal = "OK"
    ObjListIE.Visible = false
End Function

' CANCELボタン押下時
Function Click_Cancel
    RetVal = "Cancel"
    ObjListIE.Visible = false
End Function

'###########################################################

'###########################################################
'            オブジェクトのプロパティ値を取得
' 関数
'    GetPropertyVal(Obj As Object, PropName As String, ErrVal As Variant)
'
' 引数
'         Obj：プロパティを取得するオブジェクト
'    PropName：取得するプロパティ名
'      ErrVal：取得できない場合に返す値
'
' 戻り値
'    オブジェクトのプロパティ値を返す。
'    オブジェクトが指定されたプロパティ名を持っていない場合はErrValを返す。
'
' 制限事項
'    直前のエラーがクリアされる

Function GetPropertyVal(Obj, PropName, ErrVal)
    Err.Clear
    On Error Resume Next
    GetPropertyVal = Eval("Obj." & PropName)
    
    If (Err.Number <> 0) Then
        GetPropertyVal = ErrVal
        Err.Clear
    End If

End Function
'###########################################################

イベントフック

簡単なチュートリアル