131 lines
4.4 KiB
Tcl
131 lines
4.4 KiB
Tcl
# ------------------------------------------------------------------------------
|
|
# messagedlg.tcl
|
|
# This file is part of Unifix BWidget Toolkit
|
|
# ------------------------------------------------------------------------------
|
|
# Index of commands:
|
|
# - MessageDlg::create
|
|
# ------------------------------------------------------------------------------
|
|
|
|
namespace eval MessageDlg {
|
|
Dialog::use
|
|
|
|
Widget::tkinclude MessageDlg message .frame.msg \
|
|
remove [list -cursor -highlightthickness \
|
|
-highlightbackground -highlightcolor \
|
|
-relief -borderwidth -takefocus -textvariable \
|
|
] \
|
|
rename [list -text -message] \
|
|
initialize [list -aspect 800 -anchor c -justify center]
|
|
|
|
Widget::bwinclude MessageDlg Dialog :cmd \
|
|
remove [list -modal -image -bitmap -side -anchor -separator \
|
|
-homogeneous -padx -pady -spacing]
|
|
|
|
Widget::declare MessageDlg {
|
|
{-icon Enum info 0 {none error info question warning}}
|
|
{-type Enum user 0 {abortretryignore ok okcancel \
|
|
retrycancel yesno yesnocancel user}}
|
|
{-buttons String "" 0}
|
|
}
|
|
|
|
Widget::addmap MessageDlg "" tkMBox {
|
|
-parent {} -message {} -default {} -title {}
|
|
}
|
|
|
|
proc ::MessageDlg { path args } { return [eval MessageDlg::create $path $args] }
|
|
proc use { } {}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# Command MessageDlg::create
|
|
# ------------------------------------------------------------------------------
|
|
proc MessageDlg::create { path args } {
|
|
global tcl_platform
|
|
|
|
array set maps [list MessageDlg {} :cmd {} .frame.msg {} tkMBox {}]
|
|
array set maps [Widget::parseArgs MessageDlg $args]
|
|
Widget::initFromODB MessageDlg "$path#Message" $maps(MessageDlg)
|
|
|
|
array set dialogArgs $maps(:cmd)
|
|
|
|
set type [Widget::cget "$path#Message" -type]
|
|
set icon [Widget::cget "$path#Message" -icon]
|
|
|
|
set defb -1
|
|
set canb -1
|
|
switch -- $type {
|
|
abortretryignore {set lbut {abort retry ignore}}
|
|
ok {set lbut {ok}; set defb 0 }
|
|
okcancel {set lbut {ok cancel}; set defb 0; set canb 1}
|
|
retrycancel {set lbut {retry cancel}; set defb 0; set canb 1}
|
|
yesno {set lbut {yes no}; set defb 0; set canb 1}
|
|
yesnocancel {set lbut {yes no cancel}; set defb 0; set canb 2}
|
|
user {set lbut [Widget::cget "$path#Message" -buttons]}
|
|
}
|
|
|
|
# If the user didn't specify a default button, use our type-specific
|
|
# default, adding its flag/value to the "user" settings and to the tkMBox
|
|
# settings
|
|
if { ![info exists dialogArgs(-default)] } {
|
|
lappend maps(:cmd) -default $defb
|
|
lappend maps(tkMBox) -default $defb
|
|
}
|
|
if { ![info exists dialogArgs(-cancel)] } {
|
|
lappend maps(:cmd) -cancel $canb
|
|
}
|
|
|
|
# Same with title as with default
|
|
if { ![info exists dialogArgs(-title)] } {
|
|
set frame [frame $path -class MessageDlg]
|
|
set title [option get $frame "${icon}Title" MessageDlg]
|
|
destroy $frame
|
|
if { $title == "" } {
|
|
set title "Message"
|
|
}
|
|
lappend maps(:cmd) -title $title
|
|
lappend maps(tkMBox) -title $title
|
|
}
|
|
|
|
# Create the "user" type dialog
|
|
if { $type == "user" } {
|
|
if { $icon != "none" } {
|
|
set image [Bitmap::get $icon]
|
|
} else {
|
|
set image ""
|
|
}
|
|
eval Dialog::create $path $maps(:cmd) -image $image -modal local \
|
|
-side bottom -anchor c
|
|
foreach but $lbut {
|
|
Dialog::add $path -text $but -name $but
|
|
}
|
|
set frame [Dialog::getframe $path]
|
|
|
|
eval message $frame.msg $maps(.frame.msg) \
|
|
-relief flat -borderwidth 0 -highlightthickness 0 \
|
|
-textvariable {{}}
|
|
pack $frame.msg -side left -padx 3m -pady 1m -fill x -expand yes
|
|
|
|
set res [Dialog::draw $path]
|
|
destroy $path
|
|
} else {
|
|
# Do some translation of args into tk_messageBox syntax, then create
|
|
# the tk_messageBox
|
|
array set tkMBoxArgs $maps(tkMBox)
|
|
set tkMBoxArgs(-default) [lindex $lbut $tkMBoxArgs(-default)]
|
|
if { ![string equal $icon "none"] } {
|
|
set tkMBoxArgs(-icon) $icon
|
|
}
|
|
if { [info exists tkMBoxArgs(-parent)] } {
|
|
if { ![winfo exists $tkMBoxArgs(-parent)] } {
|
|
unset tkMBoxArgs(-parent)
|
|
}
|
|
}
|
|
set tkMBoxArgs(-type) $type
|
|
set res [eval tk_messageBox [array get tkMBoxArgs]]
|
|
set res [lsearch $lbut $res]
|
|
}
|
|
Widget::destroy "$path#Message"
|
|
return $res
|
|
}
|