Keith Vetter 2004-03-31 : Recently I added printing capabilities to a large tcl project using the excellent GDI package by Michael I. Schwartz [L1 ]. Initially the user could only print the entire visible part of a canvas window, but then I wanted the user to be able to select a portion of the window to print.
Thus, I needed, what I call for the lack of a better phrase, a print area selector. This is a control that lets the user select a portion of canvas that should get printed. It is a stippled rectangle which the user can resize by grabbing a corner or an edge, and move by grabbing in the middle.
The trickiest part was handling the cursor: when the mouse is on or just inside an edge or corner--in the grab zone so to speak--it should change shape. To do this required using invisible rectangles (which are made visible if you turn on debug in the demo). Also, according to the tk cursors man page [L2 ], Unix doesn't have the double headed diagonal arrow cursor (called size_nw_se and size_ne_sw on Windows).
I'm surprised that this type of control hadn't already been written--I guess this is because printing is such a pain in tcl/tk that people just don't do it. Anyway, this control, may hopefully help ease some of that pain.
##+##########################################################################
#
# PrintBox -- demonstrates a print area selection control
# by Keith Vetter, March 29, 2004
#
# Usage:
# ::PrintBox::Create <canvas widget>
# set xy [::PrintBox::Done <canvas widget>
#
package require Tk
catch {namespace delete ::PrintBox}
namespace eval ::PrintBox {
variable xy {} ;# Coordinates of print box
variable CURSORS ;# Cursors to use while resizing
variable bxy {} ;# Button down location
variable bdown 0 ;# Button is down flag
variable minSize 150 ;# Minimum size of print box
variable grabSize 10 ;# Size of "grab" area
variable debug 0
if {$::tcl_platform(platform) == "windows"} {
array set CURSORS {
L size_we R size_we
B size_ns T size_ns
TL size_nw_se BR size_nw_se
TR size_ne_sw BL size_ne_sw
}
} else {
array set CURSORS {
L sb_h_double_arrow R sb_h_double_arrow
B sb_v_double_arrow T sb_v_double_arrow
TL top_left_corner BR bottom_right_corner
TR top_right_corner BL bottom_left_corner
}
}
}
##+##########################################################################
#
# ::PrintBox::Create -- creates the print box on top of canvas W
#
proc ::PrintBox::Create {W} {
variable xy
variable CURSORS
variable bdown 0
# Get initial location
set w [winfo width $W]
set h [winfo height $W]
set x0 [$W canvasx 0]
set y0 [$W canvasy 0]
set x1 [expr {int($x0 + $w - $w / 8)}]
set y1 [expr {int($y0 + $h - $h / 8)}]
set x0 [expr {int($x0 + $w / 8)}]
set y0 [expr {int($y0 + $h / 8)}]
set xy [list $x0 $y0 $x1 $y1]
# Create stubs items that ::PrintBox::Resize will size correctly
$W delete pBox
$W create line 0 0 1 1 -tag {pBox diag1} -width 2 -fill red
$W create line 0 1 1 $y0 -tag {pBox diag2} -width 2 -fill red
$W create rect 0 0 1 1 -tag {pBox pBoxx} -width 2 -outline red \
-fill red -stipple gray25
$W bind pBoxx <Enter> [list $W config -cursor hand2]
$W bind pBoxx <ButtonPress-1> [list ::PrintBox::PBDown $W box %x %y]
$W bind pBoxx <B1-Motion> [list ::PrintBox::PBMotion $W box %x %y]
foreach {color1 color2} {{} {}} break
if {$::PrintBox::debug} {
foreach {color1 color2} {yellow blue} break
}
# Hidden rectangles that we bind to for resizing
$W create rect 0 0 0 1 -fill $color1 -stipple gray25 -width 0 -tag {pBox L}
$W create rect 1 0 1 1 -fill $color1 -stipple gray25 -width 0 -tag {pBox R}
$W create rect 0 0 1 0 -fill $color1 -stipple gray25 -width 0 -tag {pBox T}
$W create rect 0 1 1 1 -fill $color1 -stipple gray25 -width 0 -tag {pBox B}
$W create rect 0 0 0 0 -fill $color2 -stipple gray25 -width 0 -tag {pBox TL}
$W create rect 1 0 1 0 -fill $color2 -stipple gray25 -width 0 -tag {pBox TR}
$W create rect 0 1 0 1 -fill $color2 -stipple gray25 -width 0 -tag {pBox BL}
$W create rect 1 1 1 1 -fill $color2 -stipple gray25 -width 0 -tag {pBox BR}
foreach tag [array names CURSORS] {
$W bind $tag <Enter> [list ::PrintBox::PBEnter $W $tag]
$W bind $tag <Leave> [list ::PrintBox::PBLeave $W $tag]
$W bind $tag <B1-Motion> [list ::PrintBox::PBMotion $W $tag %x %y]
$W bind $tag <ButtonRelease-1> [list ::PrintBox::PBUp $W $tag]
$W bind $tag <ButtonPress-1> [list ::PrintBox::PBDown $W $tag %x %y]
}
::PrintBox::Resize $W
}
##+##########################################################################
#
# ::PrintBox::Done -- kills the print box and returns its coordinates
#
proc ::PrintBox::Done {W} {
variable xy
$W delete pBox
return $xy
}
##+##########################################################################
#
# ::PrintBox::Resize -- resizes the print box to ::PrintBox::xy size
#
proc ::PrintBox::Resize {W} {
variable xy
variable grabSize
foreach {x0 y0 x1 y1} $xy break
$W coords pBoxx $x0 $y0 $x1 $y1
$W coords diag1 $x0 $y0 $x1 $y1
$W coords diag2 $x1 $y0 $x0 $y1
set w1 [$W itemcget pBoxx -width] ;# NB. width extends outward
set w2 [expr {-1 * ($w1 + $grabSize)}]
foreach {x0 y0 x1 y1} [::PrintBox::GrowBox $x0 $y0 $x1 $y1 $w1] break
foreach {x0_ y0_ x1_ y1_} [::PrintBox::GrowBox $x0 $y0 $x1 $y1 $w2] break
$W coords L $x0 $y0_ $x0_ $y1_
$W coords R $x1 $y0_ $x1_ $y1_
$W coords T $x0_ $y0 $x1_ $y0_
$W coords B $x0_ $y1 $x1_ $y1_
$W coords TL $x0 $y0 $x0_ $y0_
$W coords TR $x1 $y0 $x1_ $y0_
$W coords BL $x0 $y1 $x0_ $y1_
$W coords BR $x1 $y1 $x1_ $y1_
}
##+##########################################################################
#
# ::PrintBox::GrowBox -- grows (or shrinks) rectangle coordinates
#
proc ::PrintBox::GrowBox {x0 y0 x1 y1 d} {
list [expr {$x0-$d}] [expr {$y0-$d}] [expr {$x1+$d}] [expr {$y1+$d}]
}
##+##########################################################################
#
# ::PrintBox::PBDown -- handles button down in a print box
#
proc ::PrintBox::PBDown {W tag x y} {
variable bxy [list $x $y]
variable bdown 1
}
##+##########################################################################
#
# ::PrintBox::PBUp -- handles button up in a print box
#
proc ::PrintBox::PBUp {W tag} {
variable bdown 0
}
##+##########################################################################
#
# ::PrintBox::PBEnter -- handles <Enter> in a print box
#
proc ::PrintBox::PBEnter {W tag} {
$W config -cursor $::PrintBox::CURSORS($tag)
}
##+##########################################################################
#
# ::PrintBox::PBLeave -- handles <Leave> in a print box
#
proc ::PrintBox::PBLeave {W tag} {
variable bdown
if {! $bdown} {
$W config -cursor {}
}
}
##+##########################################################################
#
# ::PrintBox::PBMotion -- handles button motion, moving or resizing as needed
#
proc ::PrintBox::PBMotion {W tag x y} {
variable bxy
variable xy
variable minSize
foreach {x0 y0 x1 y1} $xy break
foreach {dx dy} $bxy break
set dx [expr {$x - $dx}]
set dy [expr {$y - $dy}]
set w [winfo width $W]
set h [winfo height $W]
set wx0 [$W canvasx 0]
set wy0 [$W canvasy 0]
set wx1 [$W canvasx $w]
set wy1 [$W canvasy $h]
if {$tag eq "box"} { ;# Move the print box
if {$x0 + $dx < $wx0} {set dx [expr {$wx0 - $x0}]}
if {$x1 + $dx > $wx1} {set dx [expr {$wx1 - $x1}]}
if {$y0 + $dy < $wy0} {set dy [expr {$wy0 - $y0}]}
if {$y1 + $dy > $wy1} {set dy [expr {$wy1 - $y1}]}
set x0 [expr {$x0 + $dx}]
set x1 [expr {$x1 + $dx}]
set y0 [expr {$y0 + $dy}]
set y1 [expr {$y1 + $dy}]
set xy [list $x0 $y0 $x1 $y1]
set bxy [list $x $y]
} else { ;# Resize the print box
if {$tag eq "L" || $tag eq "TL" || $tag eq "BL"} {
set x0_ [expr {$x0 + $dx}]
if {$x0_ < $wx0} {
lset xy 0 $wx0
lset bxy 0 0
} elseif {$x1 - $x0_ >= $minSize} {
lset xy 0 $x0_
lset bxy 0 $x
}
}
if {$tag eq "R" || $tag eq "TR" || $tag eq "BR"} {
set x1_ [expr {$x1 + $dx}]
if {$x1_ > $wx1} {
lset xy 2 $wx1
lset bxy 0 $w
} elseif {$x1_ - $x0 >= $minSize} {
lset xy 2 $x1_
lset bxy 0 $x
}
}
if {$tag eq "T" || $tag eq "TR" || $tag eq "TL"} {
set y0_ [expr {$y0 + $dy}]
if {$y0_ < $wy0} {
lset xy 1 $wy0
lset bxy 1 0
} elseif {$y1 - $y0_ >= $minSize} {
lset xy 1 $y0_
lset bxy 1 $y
}
}
if {$tag eq "B" || $tag eq "BR" || $tag eq "BL"} {
set y1_ [expr {$y1 + $dy}]
if {$y1_ > $wy1} {
lset xy 3 $wy1
lset bxy 1 $h
} elseif {$y1_ - $y0 > $minSize} {
lset xy 3 $y1_
lset bxy 1 $y
}
}
}
::PrintBox::Resize $W
}
################################################################
#
# DEMO CODE
#
wm title . "Print Box Demo"
wm resizable . 0 0
canvas .c -width 500 -height 500 -bg lightyellow
pack [frame .ctrl -relief ridge -bd 2 -padx 5 -pady 5] \
-side right -fill both -ipady 5
pack .c -side left -fill both -expand 1
for {set i 0} {$i < 20} {incr i} {
set xy {}
foreach _ {1 2 3 4} { lappend xy [expr {rand() * 700 - 100}] }
set color [format "\#%06x" [expr {int(rand() * 0xFFFFFF)}]]
set type [expr {rand() < .5 ? "oval" : "rect"}]
set width [expr {rand() * 8 + 2}]
.c create $type $xy -fill $color -width $width
}
checkbutton .ctrl.onoff -text "Print Box" -variable S(onoff) -anchor w \
-command OnOff
checkbutton .ctrl.debug -text "Debug" -variable S(debug) -anchor w \
-command DebugToggle
label .ctrl.lxy -text "\nCoordinates"
label .ctrl.xy -textvariable ::PrintBox::xy -bd 2 -bg white -relief sunken \
-width 15
eval pack [winfo child .ctrl] -side top -fill x -anchor w
button .ctrl.about -text About -command \
[list tk_messageBox -message "Print Box Demo\nby Keith Vetter, March 2004"]
pack .ctrl.about -side bottom
proc OnOff {} {
if {$::S(onoff)} {
::PrintBox::Create .c
} else {
::PrintBox::Done .c
}
}
proc DebugToggle {} {
set xy $::PrintBox::xy
set ::PrintBox::debug $::S(debug)
if {$::S(onoff)} {
::PrintBox::Done .c
::PrintBox::Create .c
set ::PrintBox::xy $xy
::PrintBox::Resize .c
}
}
update
set S(onoff) 1
::PrintBox::Create .c
return