util/src/TclTk/tk8.6.12/tests/butGeom2.tcl

   1 # This file creates a visual test for button layout.  It is part of
   2 # the Tk visual test suite, which is invoked via the "visual" script.
   3
   4 catch {destroy .t}
   5 toplevel .t
   6 wm title .t "Visual Tests for Button Geometry"
   7 wm iconname .t "Button Geometry"
   8 wm geom .t +0+0
   9 wm minsize .t 1 1
  10
  11 label .t.l -text {This screen exercises the color options for various flavors of buttons.  Select display options below, and they will be applied to the appropriate button widgets.} -wraplength 5i
  12 pack .t.l -side top -fill both
  13
  14 button .t.quit -text Quit -command {destroy .t}
  15 pack .t.quit -side bottom -pady 2m
  16
  17 set sepId 1
  18 proc sep {} {
  19     global sepId
  20     frame .t.sep$sepId -height 2 -bd 1 -relief sunken
  21     pack .t.sep$sepId -side top -padx 2m -pady 2m -fill x
  22     incr sepId
  23 }
  24
  25 # Create buttons that control configuration options.
  26
  27 frame .t.control
  28 pack .t.control -side top -fill x -pady 3m
  29 frame .t.control.left
  30 frame .t.control.right
  31 pack .t.control.left .t.control.right -side left -expand 1 -fill x
  32 label .t.anchorLabel -text "Color:"
  33 frame .t.control.left.f -width 6c -height 3c
  34 pack .t.anchorLabel .t.control.left.f -in .t.control.left -side top -anchor w
  35 foreach opt {activebackground activeforeground background disabledforeground foreground highlightbackground highlightcolor } {
  36     #button .t.color-$opt -text $opt -command "config -$opt \[tk_chooseColor]"
  37     menubutton .t.color-$opt -text $opt -menu .t.color-$opt.m -indicatoron 1 \
  38         -relief raised -bd 2
  39     menu .t.color-$opt.m -tearoff 0
  40     .t.color-$opt.m add command -label Red -command "config -$opt red"
  41     .t.color-$opt.m add command -label Green -command "config -$opt green"
  42     .t.color-$opt.m add command -label Blue -command "config -$opt blue"
  43     .t.color-$opt.m add command -label Other... \
  44           -command "config -$opt \[tk_chooseColor]"
  45     pack .t.color-$opt -in .t.control.left.f -fill x
  46 }
  47
  48 set default disabled
  49 label .t.default -text Default:
  50 radiobutton .t.default-normal -text "Default normal" -relief flat \
  51         -command "config-but -default normal" -variable default \
  52         -value normal
  53 radiobutton .t.default-active -text "Default active" -relief flat \
  54         -command "config-but -default active" -variable default \
  55         -value active
  56 radiobutton .t.default-disabled -text "Default disabled" -relief flat \
  57         -command "config-but -default disabled" -variable default \
  58         -value disabled
  59 pack .t.default .t.default-normal .t.default-active .t.default-disabled \
  60         -in .t.control.right -anchor w
  61
  62 sep
  63 frame .t.f1
  64 pack .t.f1 -side top -expand 1 -fill both
  65 sep
  66 frame .t.f2
  67 pack .t.f2 -side top -expand 1 -fill both
  68 sep
  69 frame .t.f3
  70 pack .t.f3 -side top -expand 1 -fill both
  71 sep
  72 frame .t.f4
  73 pack .t.f4 -side top -expand 1 -fill both
  74 sep
  75
  76 label .t.l1 -text Label -bd 2 -relief sunken
  77 label .t.l2 -text "Explicit\nnewlines\n\nin the text" -bd 2 -relief sunken
  78 label .t.l3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -bd 2 -relief sunken -underline 50
  79 pack .t.l1 .t.l2 .t.l3 -in .t.f1 -side left -padx 5m -pady 3m \
  80         -expand y -fill both
  81
  82 button .t.b1 -text Button
  83 button .t.b2 -text "Explicit\nnewlines\n\nin the text"
  84 button .t.b3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -underline 50
  85 pack .t.b1 .t.b2 .t.b3 -in .t.f2 -side left -padx 5m -pady 3m \
  86         -expand y -fill both
  87
  88 checkbutton .t.c1 -text Checkbutton -variable a
  89 checkbutton .t.c2 -text "Explicit\nnewlines\n\nin the text" -variable b
  90 checkbutton .t.c3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -variable c -underline 50
  91 pack .t.c1 .t.c2 .t.c3 -in .t.f3 -side left -padx 5m -pady 3m \
  92         -expand y -fill both
  93
  94 radiobutton .t.r1 -text Radiobutton -value a
  95 radiobutton .t.r2 -text "Explicit\nnewlines\n\nin the text" -value b
  96 radiobutton .t.r3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -value c -underline 50
  97 pack .t.r1 .t.r2 .t.r3 -in .t.f4 -side left -padx 5m -pady 3m \
  98         -expand y -fill both
  99
 100 proc config {option value} {
 101     foreach w {.t.l1 .t.l2 .t.l3 .t.b1 .t.b2 .t.b3 .t.c1 .t.c2 .t.c3
 102             .t.r1 .t.r2 .t.r3} {
 103         catch {$w configure $option $value}
 104     }
 105 }
 106
 107 proc config-but {option value} {
 108     foreach w {.t.b1 .t.b2 .t.b3} {
 109         $w configure $option $value
 110     }
 111 }
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124