スクリプト置き場

Option Explicit

Dim ObjShell, ObjDict, ObjIE, Item, ObjTable, ObjFileDlg
Dim SelectIndex, SampleName, mycsv, row, cell, FileName, Ret, index, myList

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

' 選択された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

index = 0
myList = vbNullString

' テーブルの一覧をカンマ区切りで取得
For Each Item In ObjIE.document.all
    If (Item.nodename = "TABLE") Then
        myList = myList & GetPropertyVal(Item, "caption.innerText", "NoCaption") & "   (" & Replace(Left(Item.innerText, 30), ",", "，") & "),"
        objDict.Add index, Item
        index = index + 1
    End If
Next

' テーブルがある場合は不要なカンマを削除、無い場合は終了
If (right(myList,1) = ",") Then
    myList = left(mylist, len(mylist)-1)
Else
    MsgBox "対象のIEにテーブルが見つかりませんでした。" & vbCrLf & "処理を中断します。",64 , "処理の中止"
    WScript.Quit
End If

' テーブルの選択
SelectIndex = SelectList(split(myList,","), TYPE_INDEX, "取得対象のテーブルを選択してください")

' テーブルオブジェクトを取得、キャンセルされた場合は中断する
If (SelectIndex = -1) Then
    MsgBox "テーブル選択がキャンセルされました。" & vbCrLf & "テーブル情報取得処理を中止します。",64 , "処理の中止"
    WScript.Quit
Else
    Set ObjTable = objDict.Item(cint(SelectIndex))
End If

mycsv = vbnullstring

' テーブル情報をCSV形式で取得
for each row in objTable.rows
    for each cell in row.cells
        mycsv = mycsv & cell.innerText & ","
    next
    mycsv = left(mycsv, len(mycsv)-1)
    mycsv = mycsv & vbcrlf
next

' サンプルのファイル名を取得
SampleName = GetPropertyVal(ObjTable, "caption", "NoCaption") & "(" & ObjTable.summary & ").csv"

' WinXP以下の場合はダイアログに表示(Contrl + C)でコピーは可
On Error Resume Next
RetVal = False

' CSVファイルの出力先を取得
Set ObjFileDlg = CreateObject("SAFRCFileDlg.FileSave") 
ObjFileDlg.FileName = Replace(WScript.ScriptFullName, WScript.ScriptName, vbNullString) & SampleName
ObjFileDlg.FileType = "*.csv"
RetVal = ObjFileDlg.OpenFileSaveDlg

' ファイル名を取得、キャンセルされた場合はダイアログにCSVデータを表示して終了
If (RetVal) Then
    FileName = ObjFileDlg.FileName 
Else
    msgbox "CSV出力されませんでした。処理を中止します。" & vbCrLf & "取得したCSVデータは以下の通りです。" & vbCrlF & mycsv,64 , "処理の中止"
    WScript.Quit
End If

' ファイルに書き込み
FileOut FileName, mycsv, ForWriting

'###########################################################
'           指定文字列を指定ファイルに書き込む
'
' FileName : 書き込むファイル名
'  Content : 書き込む内容
'   IOMode : 書き込みの種類
'            ForWriting   → 新規書き込み
'            ForAppending → 追加書き込み
'
' 戻り値：0 → 正常終了
'        -1 → ファイル名が不正
'        -2 → 書き込み内容が空
'        -3 → モードの指定が不正

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

Function FileOut(FileName, Content, IOMode)

'引数のチェック
    If (FileName = vbNullString) Then
        FileOut = -1
        Exit Function
    End If
    If (Content = vbNullString) Then
        FileOut = -2
        Exit Function
    End If
    If (IOMode <> ForWriting And IOMode <> ForAppending) Then
        FileOut = -3
        Exit Function
    End If
    
    Dim fso, f, ts
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    '入出力モードの確認
    If (IOMode = ForWriting) Then
        '新規モードの場合は新規にファイルを作成
        fso.CreateTextFile FileName
        Set f = fso.GetFile(FileName)
        Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)
        ts.Write Content
        ts.Close
    Else
        'アペンドモードの場合は追記書き込みでファイルを開く
        Set f = fso.OpenTextFile(FileName, ForAppending, True)
        f.Write Content
        f.Close
    End If
    
    FileOut = 0
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
'###########################################################

テーブル情報取得

スクリーンショット