2012年8月12日日曜日

VBScript用入力フォーム表示関数


InternetExplorer Objectを利用してVBScriptで入力フォームを表示する関数です。
入力フォームの内容をプロパティの指定だけで表示する簡易版と、HTMLで自由に設定できるHTML版を作成しました。
実行するにはVB用Elements値取得関数が必要です。
'配列で指定したプロパティの値を入力フォームから取得する。
Dim strProps: strProps = Array("FIELD1", "FIELD2", "FIELD3")
Dim strVals: strVals = showInputFormLite("Input", strProps, 300, 200)

'取得結果の表示
Dim lngIu: lngIu = UBound(strVals)
Dim lngI
Dim strMsg: strMsg = ""
For lngI = 0 To lngIu
    If IsArray(strVals(lngI)) Then
        Dim lngJu: lngJu = UBound(strVals(lngI))
        Dim lngJ
        For lngJ = 0 To lngJu
            strMsg = strMsg & strProps(lngI) & "='" & strVals(lngI)(lngJ) & "'" & vbCrLf
        Next
    Else
        strMsg = strMsg & strProps(lngI) & "='" & strVals(lngI) & "'" & vbCrLf
    End If
Next
WScript.echo strMsg

'============================================================
'入力フォーム表示(簡易版)
Function showInputFormLite(ByRef strTitle, ByRef strProps, ByRef lngWidth, ByRef lngHeight)
    Dim lngIu: lngIu = UBound(strProps)
    Dim lngI
    Dim strHtml: strHtml = ""
    strHtml = strHtml & "<form>"
    For lngI = 0 To lngIu
        strHtml = strHtml & strProps(lngI) & ": <input type='text' name='" & strProps(lngI) & "' /><br/>"
    Next
    strHtml = strHtml & "    <input type='hidden' name='submit_flg' value='0' />"
    strHtml = strHtml & "    <input type='button' onclick = ""getElementsByName('submit_flg')(0).value = '1';"" value='OK' />"
    strHtml = strHtml & "</form>"
    
    showInputFormLite = showInputForm(strTitle, strHtml, strProps, lngWidth, lngHeight)
End Function

'入力フォーム表示(HTML版)
Function showInputForm(ByRef strTitle, ByRef strHtml, ByRef strProps, ByRef lngWidth, ByRef lngHeight)
    'IEのインスタンスを生成
    Dim objIe: Set objIe = CreateObject("InternetExplorer.Application")
    With objIe
        'インプットフォーム初期値設定
        .Width = lngWidth
        .Height = lngHeight
        .ToolBar = False
        .StatusBar = False
        .Visible = True
        .Navigate "about:blank"
        'フォームが表示されるまで待機
        Do While .Busy
            WScript.Sleep 500
        Loop
        .Document.Title = strTitle
        .Document.Body.InnerHtml = strHtml
        'ボタン押下まで待機
        On Error Resume Next
        Dim blnErr: blnErr = False
        Do While objIe.Busy Or (getElementsValueByName(objIe, "submit_flg") <> "1")
            If Err.Number <> 0 Then
                On Error GoTo 0
                blnErr = True
                Exit Do
            End If
            WScript.Sleep 500
        Loop
        Dim lngIu: lngIu = UBound(strProps)
        Dim strVals: ReDim strVals(lngIu)
        If blnErr = False Then
            Dim lngI
            For lngI = 0 To lngIu
                strVals(lngI) = getElementsValueByName(objIe, strProps(lngI))
            Next
            .Quit
        End If
    End With
    Set objIe = Nothing
    showInputForm = strVals
End Function

'指定したnameのエレメントから値を取得
Function getElementsValueByName(Byref objIe, ByRef strName)
    getElementsValueByName = getElementsValue(objIe.Document.GetElementsByName(strName))
End Function

0 件のコメント:

コメントを投稿