スクリプト置き場

Option Explicit

Dim ObjTargetList, strScript, ObjIE, ObjScript, ObjStyle, ObjDiv, obj, ObjForm
Dim CircleHalfSize, index, Ret, topValue, leftValue, strType

' 番号付けの設定値
Const CircleSize = 26        ' 円の大きさ
Const CircleColor = "blue"   ' 円の色
Const CircleWidth = 2        ' 円の縁の太さ
Const NumPaddingTop = 5      ' 数値文字列のTopパディング
Const NumPaddingLeft = 2     ' 数値文字列のLeftパディング
Const NumFontWeight = "bold" ' 数値文字列のfont-weightスタイルの値

CircleHalfSize = Fix(CircleSize / 2)

Set ObjTargetList = CreateObject("Scripting.Dictionary")

' "<tagName>,<type>"の文字列形式で番号付けを行うタグを指定
With ObjTargetList
    .Add "INPUT,checkbox",         True
    .Add "INPUT,file",             True
'   .Add "INPUT,hidden",           True
    .Add "INPUT,password",         True
    .Add "INPUT,radio",            True
    .Add "INPUT,text",             True
    .Add "INPUT,button",           True
    .Add "INPUT,image",            True
    .Add "INPUT,submit",           True
    .Add "INPUT,reset",            True
    .Add "SELECT,select-one",      True
    .Add "SELECT,select-multiple", True
    .Add "TEXTAREA,textarea",      True
'   .Add "LABEL,",                 True
    .Add "BUTTON,",                True
End With

' 追加するスクリプトの定義
strScript = vbCrLf _
& "document.onmousemove=mouseMove_;" & vbCrLf _
& "var onDragging=false;" & vbCrLf _
& "var targetId=''" & vbCrLf _
& "function mouseDown_(id)" & vbCrLf _
& "{" & vbCrLf _
& "   var Mx,My;" & vbCrLf _
& "   targetId='circle' + id" & vbCrLf _
& "   Mx=event.clientX;" & vbCrLf _
& "   My=event.clientY;" & vbCrLf _
& "   document.all(targetId).style.left=Mx+document.body.scrollLeft;" & vbCrLf _
& "   document.all(targetId).style.top=My+document.body.scrollTop;" & vbCrLf _
& "   document.all(targetId).style.zIndex=20;" & vbCrLf _
& "   onDragging = true;" & vbCrLf _
& "}" & vbCrLf _
& "function mouseUp_()" & vbCrLf _
& "{" & vbCrLf _
& "   onDragging=false;" & vbCrLf _
& "   targetId='';" & vbCrLf _
& "}" & vbCrLf _
& "" & vbCrLf _
& "function mouseMove_()" & vbCrLf _
& "{" & vbCrLf _
& "   if(onDragging)" & vbCrLf _
& "   {" & vbCrLf _
& "      var Mx,My;" & vbCrLf _
& "   " & vbCrLf _
& "      Mx=event.clientX;" & vbCrLf _
& "      My=event.clientY;" & vbCrLf _
& "      document.all(targetId).style.left=Mx+document.body.scrollLeft;" & vbCrLf _
& "      document.all(targetId).style.top=My+document.body.scrollTop;" & vbCrLf _
& "      event.returnValue=false;" & vbCrLf _
& "      event.cancelBubble = true;" & vbCrLf _
& "   }" & vbCrLf _
& "" & vbCrLf _
& "}" & vbCrLf _
& "function dblClick_(id)" & vbCrLf _
& "{" & vbCrLf _
& "   var elm;" & vbCrLf _
& "   document.getElementById('circle' + id).style.visibility='hidden';" & vbCrLf _
& "   while(true)" & vbCrLf _
& "   {" & vbCrLf _
& "      elm = document.getElementById('num' + id);" & vbCrLf _
& "      if (!elm)" & vbCrLf _
& "         break;" & vbCrLf _
& "      elm.innerText = elm.innerText-1;" & vbCrLf _
& "      id = id + 1;" & vbCrLf _
& "   }" & vbCrLf _
& "}" & vbCrLf

' 開かれているIEからオブジェクトを取得
Ret = GetSelectedIEObject("対象のIEを選択してください", ObjIE)
If (Ret = RETURN_NO_IE) Then
    MsgBox "IEが見つかりませんでした。" & vbCrLf & "番号付与処理を中止します。",64 , "処理の中止"
    WScript.Quit
ElseIf (Ret = RETURN_CANCEL) Then
    MsgBox "IEが選択がキャンセルされました。" & vbCrLf & "番号付与処理を中止します。",64 , "処理の中止"
    WScript.Quit
End If

' VMLの名前空間を設定
ObjIE.Document.namespaces.Add "v", "urn:schemas-microsoft-com:vml"

' スクリプトを追加
Set ObjScript = ObjIE.Document.createElement("script")
ObjScript.Language = "JScript"
ObjScript.Text = strScript
ObjIE.Document.Body.insertBefore (ObjScript)

' スタイルシートを追加
Set ObjStyle = ObjIE.Document.createStyleSheet
Call ObjStyle.addRule("v\:*", "behavior:url(#default#VML)")
Call ObjStyle.addRule(".myoval", "position:absolute; top:-" & CircleHalfSize & "px; left:-" & CircleHalfSize & "px; width:" & CircleSize & "px; height:" & CircleSize & "px;")
Call ObjStyle.addRule(".myspan", "position:absolute; top:" & NumPaddingTop & "px; left:" & NumPaddingLeft & "; width:" & CircleSize & "px; height:" & CircleSize & "px; text-align:center; font-weight:" & NumFontWeight & ";")

' ObjTargetListに定義されている要素に囲み文字を追加
index = 1
For Each ObjForm In ObjIE.Document.forms
     For Each obj In ObjForm
        strType = GetPropertyVal(obj, "tagName", "") & "," & GetPropertyVal(obj, "type", "")
        If (ObjTargetList.Exists(strType)) Then
            Set ObjDiv = ObjIE.Document.createElement("div")
            ObjDiv.ID = "circle" & index
            With ObjDiv.Style
                getPos obj, topValue, leftValue
                .Position = "absolute"
                .Top = topValue
                .Left = leftValue
                .Width = CircleSize
                .Height = CircleSize
                .Cursor = "hand"
            End With
            
            ObjDiv.insertAdjacentHTML "afterBegin", "<v:oval class='myoval' strokecolor='" & CircleColor & "' strokeweight='" & CircleWidth & "'><span id='num" & index & "' class='myspan' onmousedown='mouseDown_(" & index & ")' onmouseup='mouseUp_()' ondblclick='dblClick_(" & index & ")'>" & index & "</span></v:oval>"
            
            ObjIE.Document.Body.insertBefore ObjDiv
            
            index = index + 1
        End If
    Next
Next

If (index = 1) Then
    MsgBox "番号付けの対象となる要素はありませんでした。"
Else
    MsgBox index-1 & "個の番号付けを行いました。"
End If

WScript.Quit

' オブジェクトの絶対位置を取得
Function getPos(obj, ByRef retTop, ByRef retLeft)
    Dim intTop
    Dim intLeft
    intTop = CInt(obj.offsetTop)
    intLeft = obj.offsetLeft
    
    Do While (TypeName(obj.offsetparent) <> "Nothing")
        Set obj = obj.offsetparent
        intTop = intTop + obj.offsetTop
        intLeft = intLeft + obj.offsetLeft
    Loop
    retTop = intTop
    retLeft = intLeft
End Function

'###########################################################
'               選択された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 & Replace(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  = "350px"     ' (IE_WIDTH-50)程度
Const SELECT_MARGINBOTTOM = "10px"
Const IE_HEIGHT     = 150
Const IE_WIDTH      = 400
Const IE_LEFT       = 300
Const IE_TOP        = 300

Function SelectList(ItemList, RetType, Caption)

Dim ObjSelect, ObjLF, ObjButton1, ObjButton2, ObjOption, item
    
    ' キャンセル時の戻り値を設定
    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"

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

フォーム要素番号付与

スクリーンショット