人気ブログランキング | 話題のタグを見る

[VBScript] メッセージダイアログを実現する

こんにチワワ。ドーモボキです。

[VBScript] ラジオボタンダイアログを実現する その3

ラジオボタンダイアログのソースを利用して、メッセージダイアログを作成した。

実行ソース
r = MessageDlg("タイトル","キャプション","アイテム0,アイテム1,アイテム2")
[VBScript] メッセージダイアログを実現する_a0021757_21263884.gif

戻り値は、押されたボタンのインデックス (0~)。
[×]で終了した場合は、-1。



セキュリティの関係上、ocument、nClick に全角が含まれる。
利用する場合は、半角文字に打ち直してほしい。

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

by yozda | 2012-09-22 18:08 | プログラミング | Comments(0)