##+##########################################################################
 #
 # 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

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References