[VBScript] メッセージダイアログを実現する
2012年 09月 22日
ラジオボタンダイアログのソースを利用して、メッセージダイアログを作成した。
実行ソース
r = MessageDlg("タイトル","キャプション","アイテム0,アイテム1,アイテム2")
戻り値は、押されたボタンのインデックス (0~)。
[×]で終了した場合は、-1。
セキュリティの関係上、Document、onClick に全角が含まれる。
利用する場合は、半角文字に打ち直してほしい。
MessageDlgソース
' sTitle : タイトル
' sCaption : メッセージ
' RadioItems : ラジオアイテムリスト (配列)
' DefaultIndex : デフォルト選択するアイテムインデックス
Function MessageDlg(sTitle, sCaption, BottonCaptions)
Dim objIE,disp_h,disp_w
Dim i,r,html
r = -1
If Not IsArray(BottonCaptions) Then BottonCaptions = Split(BottonCaptions,",")
' IEを起動
Set objIE = WScript.CreateObject("InternetExplorer.Application")
objIE.Navigate "about:blank"
' タグ記述
html = "<BODY><TABLE ID=Tbl BORDER=0 STYLE=font-size:10pt>" &_
"<TR><TD ALIGN=Left VALIGN=Top>" & Replace(sCaption,vbCRLF,"<BR>") &_
"<FORM NAME=Form><INPUT TYPE=Hidden NAME=Button VALUE=-1></TD></TR>" &_
"<TR><TD ALIGN=Center VALIGN=Center>"
' ボタン
html = html & "<INPUT TYPE=BUTTON VALUE=" & BottonCaptions(0) & " onClick=Button.value=0>"
For i = 1 To UBound(BottonCaptions)
html = html & " <INPUT TYPE=BUTTON VALUE=" & BottonCaptions(i) & " onClick=Button.value=" & i & ">"
Next
html = html & "</TD></TR></FORM></TABLE></BODY>"
' ↓↓共通↓↓
objIE.Document.Body.InnerHtml = html
objIE.Document.Title = sTitle
Call GetResolution(disp_h, disp_w) ' 解像度取得
objIE.Toolbar = 0 ' 上ツールバーを隠す
objIE.StatusBar = False ' 下ステータスバーを隠す
objIE.Document.Body.RuntimeStyle.OverflowX = "hidden" ' 横 スクロールバーを隠す
objIE.Document.Body.RuntimeStyle.OverflowY = "hidden" ' 縦 〃
objIE.Width = objIE.Document.All.Tbl.clientWidth +50 ' 幅 サイズ調整
objIE.Height = objIE.Document.All.Tbl.clientHeight +70 ' 高 〃
objIE.Left = Int((disp_w -objIE.Width )/2) ' 左 位置調整
objIE.Top = Int((disp_h -objIE.Height)/2) ' 上 〃
For i = 0 To objIE.Width
objIE.Document.Title = objIE.Document.Title +" " ' - Microsoft Internet Explorerを隠す
i = i +10
Next
objIE.Document.Body.bgcolor = "ButtonFace" ' 色
objIE.Visible = True ' ウィンドウ表示
objIE.Resizable = False ' ウィンドウサイズ固定 ※表示前に実行すると縁にゴミ画像が残る
' ユーザ操作取得
On Error Resume Next ' エラー無視 ([×]終了対応)
Set ieDoc = objIE.Document
Do While r = -1
WScript.Sleep 100
r = CInt(ieDoc.Form.Button.value)
If objIE = Null Then Exit Do
Loop
objIE.Visible = False
objIE.Quit ' IEを終了
Set objIE = Nothing
' ↑↑共通↑↑
MessageDlg = r
On Error GoTo 0 'エラー無視を解除
End Function
解像度取得関数
'-----------------------------------------------------------------------------------------
' 解像度を取得
Sub GetResolution(ByRef wHeight, ByRef wWidth)
Dim Locator,Service,OfeSet
Set Locator = WScript.CreateObject("WbemScripting.SWbemLocator")
Set Service = Locator.ConnectServer
Set QfeSet = Service.ExecQuery("Select * From Win32_VideoController")
For Each Qfe In QfeSet
If Qfe.CurrentHorizontalResolution <> nil then ' 複数ディスプレイ出力PC対応
wWidth = Qfe.CurrentHorizontalResolution
wHeight= Qfe.CurrentVerticalResolution
End If
Next
End Sub