1 2if {![info exists UseNativeDialogs] || $UseNativeDialogs == ""} { 3 if {$tcl_platform(platform) == "windows"} { 4 set UseNativeDialogs 1 5 } else { 6 set UseNativeDialogs 0 7 } 8} 9 10#----- pop-up dialog window - borrowed from tk_dialog 11 12proc dialog {w x y title text bitmap default args} { 13 global _DialogDone 14 catch {destroy $w} 15 toplevel $w -class Dialog 16 wm title $w $title 17 if {$x != {} && [winfo exists $x] && [winfo ismapped $x]} { 18 wm transient $w [winfo toplevel $x] 19 } else { 20 wm transient $w [winfo toplevel [winfo parent $w]] 21 } 22 23 frame $w.top -relief raised -bd 1 24 pack $w.top -side top -fill both 25 26 message $w.msg -width 10c -text $text 27 pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 5 -pady 5 28 if {$bitmap != ""} { 29 if {![catch {image type $bitmap} type] && $type == "photo"} { 30 label $w.bitmap -image $bitmap 31 } else { 32 label $w.bitmap -bitmap $bitmap 33 } 34 pack $w.bitmap -in $w.top -side left -padx 5 -pady 5 35 } 36 37 set nbut 0 38 set wbut 0 39 set fbut $w 40 foreach but $args { 41 if {$but != ""} { 42 incr nbut 43 if {$wbut < [string length $but]} { 44 set wbut [string length $but] 45 } 46 } 47 } 48 if {$nbut} { 49 if {$wbut < 4} {set wbut 4} 50 frame $w.bot -relief raised -bd 1 51 pack $w.bot -side bottom -fill both 52 set i 0 53 foreach but $args { 54 if {$but != ""} { 55 button $w.button$i -text $but -width $wbut -command "set _DialogDone $i" 56 pack $w.button$i -in $w.bot -side left -expand 1 -padx 3 -pady 5 57 if {$i == $default} { 58 set fbut $w.button$i 59 $fbut configure -default active 60 bind $w <Return> "$fbut flash; set _DialogDone $i" 61 } 62 } 63 incr i 64 } 65 } 66 67 center_window $w $x $y 68 69 if {!$nbut} { 70 update idletasks 71 return 0 72 } 73 74 set oldFocus [focus] 75 set oldGrab [grab current $w] 76 if {$oldGrab != ""} { 77 set grabStatus [grab status $oldGrab] 78 } 79 catch {grab $w} 80 tkwait visibility $w 81 focus $fbut 82 tkwait variable _DialogDone 83 catch {focus $oldFocus} 84 destroy $w 85 if {$oldGrab != ""} { 86 if {$grabStatus == "global"} { 87 grab -global $oldGrab 88 } else { 89 grab $oldGrab 90 } 91 } 92 return $_DialogDone 93} 94 95proc MessageBox {title msg {icon ""} {type ""} {default ""}} { 96 global UseNativeDialogs 97 if {$UseNativeDialogs} { 98 set cmd "tk_messageBox -title {$title} -message {$msg}" 99 if {$icon != ""} { 100 append cmd " -icon $icon" 101 } 102 if {$type != ""} { 103 append cmd " -type $type" 104 } 105 if {$default != ""} { 106 append cmd " -default $default" 107 } 108 return [eval $cmd] 109 } 110 111 set buttons OK 112 case $type { 113 abortretryignore {set buttons "Abort Retry Ignore"} 114 okcancel {set buttons "OK Cancel"} 115 retrycancel {set buttons "Retry Cancel"} 116 yesno {set buttons "Yes No"} 117 yesnocancel {set buttons "Yes No Cancel"} 118 } 119 set defbut 0 120 if {$default != ""} { 121 set n 0 122 foreach b [split $buttons] { 123 if {$default == [string tolower $b]} { 124 set defbut $n 125 break 126 } 127 incr n 128 } 129 } 130 set cmd "dialog .messagewin {} {} {$title} {$msg} \ 131 {$icon} $defbut $buttons" 132 set n [eval $cmd] 133 if [catch {lindex $buttons $n} result] { 134 return "" 135 } 136 return [string tolower $result] 137} 138 139proc DialogBox {w x y title text bitmap args} { 140 global _DialogDone 141 142 # get button width 143 144 set width 0 145 foreach btn $args { 146 if {[string length [lindex $btn 0]] > $width} { 147 set width [string length [lindex $btn 0]] 148 } 149 } 150 if !$width { 151 return [dialog $w $x $y $title $text $bitmap {} {}] 152 } 153 incr width 2 154 155 catch {destroy $w} 156 toplevel $w -class Dialog 157 wm title $w $title 158 if {$x != {} && [winfo exists $x] && [winfo ismapped $x]} { 159 wm transient $w [winfo toplevel $x] 160 } else { 161 wm transient $w [winfo toplevel [winfo parent $w]] 162 } 163 164 # top message 165 166 frame $w.msg -relief raised -bd 1 167 pack $w.msg -side top -fill both -expand 1 168 if {$bitmap != ""} { 169 if {![catch {image type $bitmap} type] && $type == "photo"} { 170 label $w.msg.icon -image $bitmap 171 } else { 172 label $w.msg.icon -bitmap $bitmap 173 } 174 pack $w.msg.icon -side left -padx 10 -pady 3 175 } 176 message $w.msg.msg -text $text -width 8c 177 pack $w.msg.msg -pady 3 -anchor w 178 179 # button selections 180 181 set cnt -1 182 foreach btn $args { 183 incr cnt 184 set f [frame $w.f$cnt -relief raised -bd 1] 185 pack $f -side top -fill x 186 button $f.btn -width $width -text [lindex $btn 0] \ 187 -padx 3 -pady 2 -command "set _DialogDone $cnt" 188 pack $f.btn -side left -padx 3 -pady 3 189 pack $f.btn -side left 190 message $f.msg -text [lindex $btn 1] -width 10c 191 pack $f.msg -anchor w -padx 3 -pady 3 192 } 193 194 center_window $w $x $y 195 196 set oldFocus [focus] 197 set oldGrab [grab current $w] 198 if {$oldGrab != ""} { 199 set grabStatus [grab status $oldGrab] 200 } 201 catch {grab $w} 202 focus $w 203 tkwait variable _DialogDone 204 catch {focus $oldFocus} 205 destroy $w 206 if {$oldGrab != ""} { 207 if {$grabStatus == "global"} { 208 grab -global $oldGrab 209 } else { 210 grab $oldGrab 211 } 212 } 213 return $_DialogDone 214} 215 216#----- error message popup window 217 218proc errormsg {msg {x -1} {y -1}} { 219 if {$msg != ""} { 220 dialog .errorwin $x $y Error $msg error 0 Dismiss 221 } 222} 223 224proc ErrorMessage {msg} { 225 MessageBox Error "$msg" error 226} 227 228#----- center a window 229 230proc center_window {w xref {yref -1}} { 231 wm withdraw $w 232 update idletasks 233 set ww [winfo reqwidth $w] 234 set wh [winfo reqheight $w] 235 236 if {$xref == ""} { 237 set x [expr ([winfo screenwidth $w] - $ww) / 2] 238 set y [expr ([winfo screenheight $w] - $wh) / 2] 239 } elseif {[winfo exists $xref] && [winfo ismapped $xref]} { 240 set x [expr [winfo rootx $xref] + ([winfo width $xref] - $ww) / 2] 241 set y [expr [winfo rooty $xref] + ([winfo height $xref] - $wh) / 2] 242 } else { 243 if [catch {expr $xref < 0} x] { 244 set x 1 245 } 246 if {$x} { 247 if [winfo ismapped .] { 248 set x [expr [winfo rootx .] + ([winfo width .] - $ww) / 2] 249 } else { 250 set x [expr ([winfo screenwidth $w] - $ww) / 2] 251 } 252 } else { 253 set x [expr $xref - $ww / 2] 254 } 255 if [catch {expr $yref < 0} y] { 256 set y 1 257 } 258 if {$y} { 259 if [winfo ismapped .] { 260 set y [expr [winfo rooty .] + ([winfo height .] - $wh) / 2] 261 } else { 262 set y [expr ([winfo screenheight $w] - $wh) / 2] 263 } 264 } else { 265 set y [expr $yref - $wh / 2] 266 } 267 } 268 269 if {$x < 0} { 270 set pos +0 271 } elseif {[expr $x + $ww] > [winfo screenwidth $w]} { 272 set pos -0 273 } else { 274 set pos +$x 275 } 276 277 if {$y < 0} { 278 set pos $pos+0 279 } elseif {[expr $y + $wh] > [winfo screenheight $w]} { 280 set pos $pos-0 281 } else { 282 set pos $pos+$y 283 } 284 285 wm geometry $w $pos 286 update idletasks 287 wm deiconify $w 288} 289 290#----- about message window 291 292proc about {title text {bitmap ""}} { 293 dialog .about -1 -1 $title $text $bitmap 0 Close 294} 295 296#----- popup message 297 298proc popup_message {msg args} { 299 global Font 300 301 set font $Font(normal) 302 set bg #ffffcc 303 set fg black 304 set parent . 305 set pos "" 306 set width 5c 307 set wrap 1 308 foreach {opt val} $args { 309 switch -glob -- $opt { 310 -fon* {set font $val} 311 -par* {set parent $val} 312 -pos* {set pos $val} 313 -for* - -fg {set fg $val} 314 -bac* - -bg {set bg $val} 315 -wid* {set width $val} 316 -wra* {set wrap $val} 317 } 318 } 319 if {$pos == ""} {set pos $parent} 320 321 set w .popup 322 catch {destroy $w} 323 toplevel $w -bg black 324 wm overrideredirect $w 1 325 wm transient $w [winfo toplevel $parent] 326 if {$wrap} { 327 message $w.l -text $msg -font $font -relief flat -bg $bg -fg $fg \ 328 -padx 2 -pady 0 -anchor w -width $width 329 } else { 330 label $w.l -text $msg -font $font -relief flat -bg $bg -fg $fg \ 331 -padx 2 -pady 0 -anchor w -justify left -wraplength 0 332 } 333 pack $w.l -side left -padx 1 -pady 1 334 eval center_window $w $pos 335 336 bind $w <ButtonRelease> {catch {destroy .popup};break} 337 bind $w <KeyRelease> {catch {destroy .popup};break} 338 bind $w <FocusOut> {catch {destroy .popup}} 339 340 set oldFocus [focus] 341 set oldGrab [grab current $w] 342 if {$oldGrab != ""} { 343 set grabStatus [grab status $oldGrab] 344 } 345 catch {grab $w} 346 focus $w 347 tkwait window $w 348 catch {focus $oldFocus} 349 if {$oldGrab != ""} { 350 if {$grabStatus == "global"} { 351 grab -global $oldGrab 352 } else { 353 grab $oldGrab 354 } 355 } 356} 357 358