Updated 2011-07-20 03:07:23 by RLE ▲

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

Category GraphicsCategory GUI