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