home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tk42r2x.zip / TclTk / lib / tk4.2 / dialog.tcl < prev    next >
Text File  |  1999-07-27  |  5KB  |  157 lines
  1. # dialog.tcl --
  2. #
  3. # This file defines the procedure tk_dialog, which creates a dialog
  4. # box containing a bitmap, a message, and one or more buttons.
  5. #
  6. # SCCS: @(#) dialog.tcl 1.26 96/05/07 09:30:31
  7. #
  8. # Copyright (c) 1992-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. #
  16. # tk_dialog:
  17. #
  18. # This procedure displays a dialog box, waits for a button in the dialog
  19. # to be invoked, then returns the index of the selected button.  If the
  20. # dialog somehow gets destroyed, -1 is returned.
  21. #
  22. # Arguments:
  23. # w -        Window to use for dialog top-level.
  24. # title -    Title to display in dialog's decorative frame.
  25. # text -    Message to display in dialog.
  26. # bitmap -    Bitmap to display in dialog (empty string means none).
  27. # default -    Index of button that is to display the default ring
  28. #        (-1 means none).
  29. # args -    One or more strings to display in buttons across the
  30. #        bottom of the dialog box.
  31.  
  32. proc tk_dialog {w title text bitmap default args} {
  33.     global tkPriv
  34.  
  35.     # 1. Create the top-level window and divide it into top
  36.     # and bottom parts.
  37.  
  38.     catch {destroy $w}
  39.     toplevel $w -class Dialog
  40.     wm title $w $title
  41.     wm iconname $w Dialog
  42.     wm protocol $w WM_DELETE_WINDOW { }
  43.  
  44.     # The following command means that the dialog won't be posted if
  45.     # [winfo parent $w] is iconified, but it's really needed;  otherwise
  46.     # the dialog can become obscured by other windows in the application,
  47.     # even though its grab keeps the rest of the application from being used.
  48.  
  49.     wm transient $w [winfo toplevel [winfo parent $w]]
  50.     frame $w.bot -relief raised -bd 1
  51.     pack $w.bot -side bottom -fill both
  52.     frame $w.top -relief raised -bd 1
  53.     pack $w.top -side top -fill both -expand 1
  54.  
  55.     # 2. Fill the top part with bitmap and message (use the option
  56.     # database for -wraplength so that it can be overridden by
  57.     # the caller).
  58.  
  59.     option add *Dialog.msg.wrapLength 3i widgetDefault
  60.     label $w.msg -justify left -text $text
  61.     catch {$w.msg configure -font \
  62.         -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
  63.     }
  64.     pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
  65.     if {$bitmap != ""} {
  66.     label $w.bitmap -bitmap $bitmap
  67.     pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
  68.     }
  69.  
  70.     # 3. Create a row of buttons at the bottom of the dialog.
  71.  
  72.     set i 0
  73.     foreach but $args {
  74.     button $w.button$i -text $but -command "set tkPriv(button) $i"
  75.     if {$i == $default} {
  76.         frame $w.default -relief sunken -bd 1
  77.         raise $w.button$i $w.default
  78.         pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m
  79.         pack $w.button$i -in $w.default -padx 2m -pady 2m
  80.     } else {
  81.         pack $w.button$i -in $w.bot -side left -expand 1 \
  82.             -padx 3m -pady 2m
  83.     }
  84.     incr i
  85.     }
  86.  
  87.     # 4. Create a binding for <Return> on the dialog if there is a
  88.     # default button.
  89.  
  90.     if {$default >= 0} {
  91.     bind $w <Return> "
  92.         $w.button$default configure -state active -relief sunken
  93.         update idletasks
  94.         after 100
  95.         set tkPriv(button) $default
  96.     "
  97.     }
  98.  
  99.     # 5. Create a <Destroy> binding for the window that sets the
  100.     # button variable to -1;  this is needed in case something happens
  101.     # that destroys the window, such as its parent window being destroyed.
  102.  
  103.     bind $w <Destroy> {set tkPriv(button) -1}
  104.  
  105.     # 6. Withdraw the window, then update all the geometry information
  106.     # so we know how big it wants to be, then center the window in the
  107.     # display and de-iconify it.
  108.  
  109.     wm withdraw $w
  110.     update idletasks
  111.     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  112.         - [winfo vrootx [winfo parent $w]]]
  113.     set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
  114.         - [winfo vrooty [winfo parent $w]]]
  115.     wm geom $w +$x+$y
  116.     wm deiconify $w
  117.  
  118.     # 7. Set a grab and claim the focus too.
  119.  
  120.     set oldFocus [focus]
  121.     set oldGrab [grab current $w]
  122.     if {$oldGrab != ""} {
  123.     set grabStatus [grab status $oldGrab]
  124.     }
  125.     grab $w
  126.     if {$default >= 0} {
  127.     focus $w.button$default
  128.     } else {
  129.     focus $w
  130.     }
  131.  
  132.     # 8. Wait for the user to respond, then restore the focus and
  133.     # return the index of the selected button.  Restore the focus
  134.     # before deleting the window, since otherwise the window manager
  135.     # may take the focus away so we can't redirect it.  Finally,
  136.     # restore any grab that was in effect.
  137.  
  138.     tkwait variable tkPriv(button)
  139.     catch {focus $oldFocus}
  140.     catch {
  141.     # It's possible that the window has already been destroyed,
  142.     # hence this "catch".  Delete the Destroy handler so that
  143.     # tkPriv(button) doesn't get reset by it.
  144.  
  145.     bind $w <Destroy> {}
  146.     destroy $w
  147.     }
  148.     if {$oldGrab != ""} {
  149.     if {$grabStatus == "global"} {
  150.         grab -global $oldGrab
  151.     } else {
  152.         grab $oldGrab
  153.     }
  154.     }
  155.     return $tkPriv(button)
  156. }
  157.