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 <B2-Motion> [bind Text <B2-Motion>]
.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