[Keith Vetter] 2006-02-13 : Here's a package I recently wrote that solves the problem of capturing the contents of a canvas into an image. If the canvas is small enough to fit entirely in the current window then you can use the Img package (see [Capture a window into an image]). This package handles the situation when the canvas is too large. It first displays a dialog letting the user select which portions of the canvas to capture, then for each section it scrolls the canvas to that section, does a screen capture and joins them together into one large image. There are some really nasty corner situations with partial sections at the edges. NB. this package doesn't handle two cases: first, if you have embedded widgets they show up as blank (a limitation of the Img package), and second, it assumes highlightthickness is set to 0. ---- ====== ##+########################################################################## # # snap.tcl -- Takes snapshot of current or multiple connected screens # by Keith Vetter, February 2006 # # Revisions: # KPV Feb 13, 2006 - initial revision # ##+########################################################################## ############################################################################# package require Tk package require Img package require tile namespace import -force ::ttk::button image create photo ::img::camera -data { R0lGODlhVQBbALMAAAQCBMzO/LT6/PwCBPz+/OkAABIAAAAAALgB394A2hgA1AAAd8CgAN7qABgS AAAAACH5BAEAAAMALAAAAABVAFsAAwT/cMhJq72Ygsy7/2AIbGFpWuN5jaTqiuw7sK1sr3QN03eP 5joP0EeUAGOfY7DoogmGHeWSeWIJrlDc6Mmj2qzXcO63xXZ3XiM4bD47xefMMa0GsO9SOz6ukdJn ZXd7b4J8eSl/gIKLXHqMPId8XoGMlY+HcIh/awIEnpZhnp+ZhGySk46iopWqq3CWY5trrapstK2g pFR5obe+v4wEpkgykYS/yL69o21TSZjBydLJw5oqOblX09vAzTfYrNzit7rfpcvj6cyNzlWc2urx 1Tp5z5Sd8erzxu0V5+M5xmVr1k+LI3zTjEnLlcXEMWn8jii7dKrELGQR85AbZK1YKoxA/yAGpLWv oEU9ySRyG7GRncmTZUCODECzpk1VLHG5fAniCMJbSjzZHErTU85amYj4/AlUpdAAh3Tu8wiOqS+n T2tiFVaoYc9/CUOKIjqS5CIl9u5Z/eUUqsaJXdEaLCUOK1G3LLrFlTv3osiyWqXALVkPw9K1rdoG poGMox+HQBCLsrs4b8udPNOio6X4boDBxHb5bSr2V9HLoZWOJl02pVlvRehuy2hZKrvY7wDyG3y7 xzl4dUs33mtOra3ZQYc7ztx3qzoAyknFuvZYQspI4vxVFDL9AtvW6iaFuJrc8+JWiT5wFkxTymno BLymH8CaNov38AOnZ7wefvzkrbQHQP9RR+mXBoD18edLewLe1yBzIEwW0mdGvUWAeTblUBluFeKU E4GCGYWhefK9cNSHUKlSWYMSukfWHKpdiBdR8a1Y01g0kBgJbgPidV+OPvZY1Ih3HcJjj3k8SOSM nhXmg4YuFjlCZQ76mCFfvmm4JBBUTqlgf9tRd4SUXHYJnowU/hemO/YBGaSGY3nWIhNtavnmfXEq kWZHxdUppJ6fmengf6KNaYyZQx1KKJ16Htogkw8mueiRUEaipFtXChlpThByZ6ilkGqK6Ys5xlco l45WKaqoXQZwYKOgqmoempu+WmaqUxKpYqS2aokrqzTu+mCvQP4KFYm0bIjKrbHm2uRkR2iuSVWx zSI5Kl7oDEsHs4coOaCzbwib2qkDCEqtl6paEeBnfC5b7qbclingHWPVON8ME8Abr51qZeXqvfnW scSfYwYmRic2AcxjplX+q7BqmgL7MKPOEjXxsiVeXKjGHBMRAQA7 } namespace eval ::Snapshot { variable WHO variable W .snap variable S variable BOX variable saveName "snapshot" variable msg "Snapshot Demo" ;# For use as -texvariable variable tops ;# For hiding other toplevels array set S {w 200 h 200} } ##+########################################################################## # # ::Snapshot::Dialog -- puts up the snapshot dialog # proc ::Snapshot::Dialog {who} { variable WHO $who variable S variable W variable BOX destroy $W toplevel $W wm title $W "Snapshot" scan [wm geom .] "%dx%d+%d+%d" w h x y wm geom $W +[expr {$x+$w+30}]+$y wm resizable $W 0 0 label $W.icon -image ::img::camera -width 100 -height 100 frame $W.btns -bd 2 -relief ridge button $W.snap -text "Take Snapshot" -command ::Snapshot::_Snap button $W.dismiss -text Dismiss -command [list destroy $W] frame $W.f -bd 5 -relief ridge -pady 5 -padx 5 canvas $W.c -highlightthickness 0 -width $S(w) -height $S(h) -bg red label $W.l1 -text "Click on cells to select" -font {Helvetica 10 bold} label $W.l2 -textvariable ::Snapshot::BOX(size) -font {Helvetica 10 bold} grid $W.icon $W.f -sticky n -pady 10 grid configure $W.f -sticky news -padx 10 grid x $W.l1 grid x $W.l2 grid $W.btns - -sticky ew grid rowconfigure $W 0 -weight 1 grid columnconfigure $W 1 -weight 1 pack $W.c -side top -in $W.f -fill both -expand 1 pack $W.snap $W.dismiss -in $W.btns -side left -expand 1 -pady 10 ::Snapshot::_MakeGrid ::Snapshot::_click $BOX(me,row) $BOX(me,col) grab $W ;# Use this if you want to freeze the display } ##+########################################################################## # # ::Snapshot::_MakeGrid -- draws the grid to select cells on # proc ::Snapshot::_MakeGrid {} { variable W variable BOX variable S $W.c delete all ::Snapshot::_GetDimensions foreach arr [array names BOX xy,*] { scan $arr "xy,%d,%d" row col set tag box$row,$col foreach {x0 y0 x1 y1} $BOX($arr) break set x0 [expr {$x0 * $S(w)}] set y0 [expr {$y0 * $S(h)}] set x1 [expr {$x1 * $S(w)}] set y1 [expr {$y1 * $S(h)}] $W.c create rect $x0 $y0 $x1 $y1 -tag [list box $tag] -width 2 \ -outline black -fill black -stipple gray50 $W.c bind $tag <1> [list ::Snapshot::_click $row $col] set BOX(val,$row,$col) 0 } } ##+########################################################################## # # ::Snapshot::_click -- handles clicking on a grid cell # proc ::Snapshot::_click {row col} { variable W variable BOX set tag box$row,$col if {$BOX(val,$row,$col) == 0} { set BOX(val,$row,$col) 1 $W.c itemconfig $tag -fill red -stipple gray75 } else { set BOX(val,$row,$col) 0 $W.c itemconfig $tag -fill black -stipple gray50 } ::Snapshot::_GetISize } ##+########################################################################## # # ::Snapshot::_GetISize -- Figures outs image size based on clicked cells # proc ::Snapshot::_GetISize {} { variable BOX variable W set cnt 0 for {set row 0} {$row < $BOX(rows)} {incr row} { for {set col 0} {$col < $BOX(cols)} {incr col} { if {$BOX(val,$row,$col) == 0} continue if {[incr cnt] == 1} { set rmin $row set rmax $row set cmin $col set cmax $col } else { if {$row < $rmin} {set rmin $row} if {$row > $rmax} {set rmax $row} if {$col < $cmin} {set cmin $col} if {$col > $cmax} {set cmax $col} } } } if {$cnt == 0} { set BOX(size) "? x ?" $W.snap config -state disabled return } set w [expr {$cmax - $cmin + 1}] set h [expr {$rmax - $rmin + 1}] $W.snap config -state [expr {$cnt == ($w*$h) ? "normal" : "disabled"}] foreach var {rmin rmax cmin cmax} { set BOX($var) [set $var] } foreach {. . w h} [::Snapshot::_GetToCoords $BOX(rmax) $BOX(cmax)] break set BOX(size) "[comma $w] x [comma $h]" set BOX(cnt) $cnt } ##+########################################################################## # # ::Snapshot::_GetDimensions -- get scroll percentages for all cells # proc ::Snapshot::_GetDimensions {} { variable WHO variable BOX unset -nocomplain BOX # Get size of whole screen set bbox [$WHO cget -scrollregion] if {$bbox eq ""} { set bbox [$WHO bbox all]} if {$bbox eq ""} {error problem} set ::bbox $bbox foreach {l t r b} $bbox break set BOX(s,w) [expr {$r - $l}] set BOX(s,h) [expr {$b - $t}] foreach {xlo xxhi} [$WHO xview] break foreach {ylo yyhi} [$WHO yview] break set wx [expr {$xxhi - $xlo}] set wy [expr {$yyhi - $ylo}] for {set x $xlo} {$x > $wx} {set x [expr {$x - $wx}]} {} set xx 0 if {$x == 0} {set x $wx} while {$x < 1} { lappend xx $x set x [expr {$x + $wx}] } lappend xx 1 set BOX(cols) [expr {[llength $xx]-1}] for {set y $ylo} {$y > $wy} {set y [expr {$y - $wy}]} {} set yy 0 if {$y == 0} {set y $wy} while {$y < 1} { lappend yy $y set y [expr {$y + $wy}] } lappend yy 1 set BOX(rows) [expr {[llength $yy]-1}] # Now we can compute coordinates for all the boxes for {set col0 0; set col1 1} {$col1 < [llength $xx]} {incr col0; incr col1} { set xlo [lindex $xx $col0] set xhi [lindex $xx $col1] if {abs($xhi - $xxhi) < .0001} { set BOX(me,col) $col0 } for {set row0 0; set row1 1} {$row1 < [llength $yy]} {incr row0; incr row1} { set ylo [lindex $yy $row0] set yhi [lindex $yy $row1] if {abs($yhi - $yyhi) < .0001} { set BOX(me,row) $row0 } set BOX(xy,$row0,$col0) [list $xlo $ylo $xhi $yhi] } } } ##+########################################################################## # # ::Snapshot::_Snap -- High level handler for capturing image # proc ::Snapshot::_Snap {} { variable W variable msg "Taking Snapshot..." destroy $W ::Snapshot::HideToplevels 1 set iname [::Snapshot::_MakeImage] ::Snapshot::HideToplevels 0 ::Snapshot::_Save $iname image delete $iname } ##+########################################################################## # # ::Snapshot::_MakeImage -- middle level handler for creating image # proc ::Snapshot::_MakeImage {} { variable BOX variable msg set iname ::snap::img set tname ::snap::tmp foreach cmd [info commands ::snap::*] {image delete $cmd} foreach {. . w h} [::Snapshot::_GetToCoords $BOX(rmax) $BOX(cmax)] break image create photo $iname -width $w -height $h set cnt 0 for {set row $BOX(rmin)} {$row <= $BOX(rmax)} {incr row} { for {set col $BOX(cmin)} {$col <= $BOX(cmax)} {incr col} { incr cnt set msg "Taking snapshot $cnt/$BOX(cnt)" ::Snapshot::_MakeOneImage $tname $row $col set to [::Snapshot::_GetToCoords $row $col] set from [::Snapshot::_GetFromCoords $row $col $tname] eval $iname copy $tname -to $to -from $from } } image delete $tname ::Snapshot::_MoveTo $BOX(me,row) $BOX(me,col) return $iname } ##+########################################################################## # # ::Snapshot::_MakeOneImage -- lowest level handler for creating image # proc ::Snapshot::_MakeOneImage {iname row col} { variable WHO ::Snapshot::_MoveTo $row $col if {[info commands $iname] ne ""} {image delete $iname} image create photo $iname -data $WHO return $iname } ##+########################################################################## # # ::Snapshot::_GetToCoords -- returns coords where this cell goes in # the final image # proc ::Snapshot::_GetToCoords {row col} { variable BOX # Get top left corner of image in percentages foreach {xx yy} $BOX(xy,$BOX(rmin),$BOX(cmin)) break foreach {x0 y0 x1 y1} $BOX(xy,$row,$col) break set x0 [expr {round(($x0-$xx) * $BOX(s,w))}] set x1 [expr {round(($x1-$xx) * $BOX(s,w))}] set y0 [expr {round(($y0-$yy) * $BOX(s,h))}] set y1 [expr {round(($y1-$yy) * $BOX(s,h))}] return [list $x0 $y0 $x1 $y1] } ##+########################################################################## # # ::Snapshot::_GetFromCoords -- for the extreme right column # and bottom row we might have to grab from within the image # proc ::Snapshot::_GetFromCoords {row col img} { variable BOX set fromX 0 set fromY 0 foreach {x0 y0 x1 y1} $BOX(xy,$row,$col) break if {$x1 >= 1 && $x0 > 0} { set needX [expr {round($BOX(s,w) * ($x1-$x0))}] set fromX [expr {[image width $img] - $needX}] } if {$y1 >= 1 && $y0 > 0} { set needY [expr {round($BOX(s,h) * ($y1-$y0))}] set fromY [expr {[image height $img] - $needY}] } return [list $fromX $fromY] } ##+########################################################################## # # ::Snapshot::_MoveTo -- Moves screen so a given cell is visible # proc ::Snapshot::_MoveTo {row col} { variable WHO variable BOX foreach {xmin ymin} $BOX(xy,$row,$col) break $WHO xview moveto $xmin $WHO yview moveto $ymin update } ##+########################################################################## # # ::Snapshot::_Save -- Saves our image in a file # proc ::Snapshot::_Save {iname} { variable saveName variable msg set types {} lappend types {"JPEG Files" ".jpg"} lappend types {"PNG Files" ".png"} set ext "jpg" set fname [tk_getSaveFile -defaultextension $ext \ -title "Save Snapshot" \ -filetypes $types \ -initialfile $saveName] if {$fname eq ""} { set msg "Cancelled snapshot" return } set saveName $fname set fmt [expr {[file extension $saveName] eq ".png" ? "png" : "jpeg"}] $iname write $saveName -format $fmt set msg "Saved snapshot as $saveName" } ##+########################################################################## # # ::Snapshot::HideToplevels -- withdraws all top levels so the # main window is not obscured # proc ::Snapshot::HideToplevels {hide} { variable tops if {$hide} { set tops {} foreach w [winfo child .] { if {[winfo class $w] ne "Toplevel"} continue lappend tops $w [wm state $w] if {[wm state $w] eq "normal"} { wm withdraw $w } } raise . update } else { foreach {w wstate} $tops { if {$wstate eq "normal"} { wm deiconify $w } } } } proc comma { num {sep ,} } { while {[regsub {^([-+]?\d+)(\d\d\d)} $num "\\1$sep\\2" num]} {} return $num } ################################################################ # # Demo code # scrollbar .sb_x -command {.c xview} -orient horizontal scrollbar .sb_y -command {.c yview} -orient vertical canvas .c -highlightthickness 0 bind .c <2> [bind Text <2>] ;# Enable dragging w/ <2> bind .c [bind Text ] .c config -xscrollcommand {.sb_x set} .c config -yscrollcommand {.sb_y set} label .l -textvariable ::Snapshot::msg -font {Times 12 bold} -bd 2 -relief ridge button .go -text "Snapshot" -command {::Snapshot::Dialog .c} ::ttk::separator .sep grid .c .sb_y -sticky news grid .sb_x -sticky news #grid .sep - -sticky ew -pady 20 -padx 10 grid .l - -sticky news grid .go - -pady 10 grid rowconfigure . 0 -weight 1 grid columnconfigure . 0 -weight 1 for {set i 0} {$i < 200} {incr i} { set x0 [expr {rand() * 1000 - 500}] set y0 [expr {rand() * 1000 - 500}] set x1 [expr {$x0 + rand()*200}] set y1 [expr {$y0 + rand()*200}] set clr [format "\#%06x" [expr {int(rand()*0xFFFFFF)}]] set clr2 [format "\#%06x" [expr {int(rand()*0xFFFFFF)}]] set width [expr {rand() * 5}] set type [expr {rand() < .5 ? "oval" : "rect"}] .c create $type $x0 $y0 $x1 $y1 -fill $clr -width $width -outline $clr2 } .c config -scrollregion [.c bbox all] return ====== <> Graphics | GUI