選択IEオブジェクト取得関数

Option Explicit

' テスト用コード
Dim Ret, ObjIE
Ret = GetSelectedIEObject("IEを選択してください", ObjIE)

If (Ret = RETURN_NO_IE) Then
   MsgBox "IEが見つかりませんでした"
ElseIf (Ret = RETURN_CANCEL) Then
   MsgBox "選択がキャンセルされました"
Else
   MsgBox TypeName(ObjIE)
End If

'###########################################################
'               選択された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  = "100%"
Const SELECT_MARGINBOTTOM = "10px"
Const IE_HEIGHT     = 150
Const IE_WIDTH      = 350

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.innerText = "CANCEL"
    ObjButton1.style.styleFloat = "right"
    ObjListIE.Document.Body.insertBefore(ObjButton1)
    Set ObjButton1.onclick = GetRef("Click_Cancel")
    
    ' OKボタンを追加
    Set ObjButton2 = ObjListIE.Document.createElement("button")
    ObjButton2.innerText = "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
        .AddressBar = false
        .MenuBar    = false
        .Resizable  = true
        .StatusBar  = false
        .ToolBar    = false
        .Visible    = true
    End With
    
    ' 大きさ変更時のイベントを設定
    Set ObjListIE.Document.body.onresize = GetRef("OnFormResize")
    
    ObjListIE.Document.title = "ドロップダウン選択"

Do While(ObjListIE.Busy)
        WScript.Sleep 100
    Loop
    
    ' IEをアクティブ化
    activateIe ObjListIE

' ボタン押下まで待機
    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

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

' 高さが最小値を下回った場合は最小値に設定
    If (ObjListIE.Height < IE_HEIGHT) Then
        ObjListIE.Height = IE_HEIGHT
    End If
    
    ' 幅が最小値を下回った場合は最小値に設定
    If (ObjListIE.Width < IE_WIDTH) Then
        ObjListIE.Width = IE_WIDTH
    End If
    
End Sub

' 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

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

'###########################################################
'            オブジェクトのプロパティ値を取得
' 関数
'    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
'###########################################################