Tcl/tk screenshot widget

Purpose

A TclOO class which implements a so called “screen shot” widget.

The function non only allows to take a screen shot from a native tk widget, like for example the image create photo -format window -data $mywidget command, but also works to capture any portion of the screen.

Implementation

  • The screen picture is captured with the loupe utility function included in the treectrl (binary) package.

  • To save the image to various image file formats, the Img package is not mandatory but recommended.

  • The code can be used nearly “stand alone”, so it might be useful for various other application, e.g. like a note taken application, etc…

Hints

  • The code has only been tested on windows (so far).
  • A life example of how this function can be integrated in a real live application is the DBM application which is also available on this site.

Credits

This code is based on and influenced by the ruler widget and screenruler dialog originally written by Jeffrey Hobbs. The aformentioned code is avaliable in tklib.

Please note that although the package contains a test script, it possibly will not work out of the box as there are some dependencies as mentioned above.

To overcome this limitation, some might want to use a battery-included binary or a full featured tcl/tk installation e.g. provided by Activestate.

The source code of the latest version is available here.

File name:Size / byte:
screenshot0.2.4.zip91964

Related article

There is also an article “Yet another Screenshot application” on this web site.

Revision history

Sourcecode of screenshot.tcl...


# -----------------------------------------------------------------------------
# screenshot.tcl ---
# -----------------------------------------------------------------------------
# (c) 2018, Johann Oberdorfer - Engineering Support | CAD | Software
#     johann.oberdorfer [at] gmail.com
#     www.johann-oberdorfer.eu
# -----------------------------------------------------------------------------
# This source file is distributed under the BSD license.
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#   See the BSD License for more details.
# -----------------------------------------------------------------------------
# Purpose:
#   A TclOO class which implements a convinient way to create a screen shot.
#   The screenshot not only works "internally" for tk widgets such as for
#   example the [image create photo -format window -data $mywidget] command,
#   but for any  portion of the display.
# Implementation:
#   The screen picture is captured with the "loupe" utility function
#   included in the treectrl (binary) package. To save the image to various
#   image file formats, the Img package is also required.
#
#   Code can be used nearly "stand alone" but might be usefull for
#   some other application, e.g. like a note taken application, etc...
# -----------------------------------------------------------------------------
# TclOO naming conventions:
#   public methods  - starts with lower case declaration names, whereas
#   private methods - starts with uppercase naming, so we use CamelCase ...
# -----------------------------------------------------------------------------
#
# Credits:
#   This code is based on and influenced by the
#   "ruler widget and screenruler dialog" originally written by Jeffrey Hobbs.
#   The aformentioned code is avaliable in tklib.
# -----------------------------------------------------------------------------
# Revision history:
#   18-01-04: J.Oberdorfer, Initial release
#   18-04-15: Johann, V0.2, ResizeHandler added
#   18-09-24: Johann, -screenshotcancelcommand added
#   20-11-03: Johann, fixed a small linux bug
#                    - thanks t the feedback of "apIsimple"
#	on: https://wiki.tcl-lang.org/page/A+Screenshot+Widget+implemented+with+TclOO?V=8
#                    KeyPress-Return binding added, thank's to Weiwu Zhang for
#                    his suggestion
#
#   XX-XX-XX: Comments and improvements whatsover are very welcome.
# -----------------------------------------------------------------------------

package require Tk
package require TclOO
package require treectrl
package require Img

package provide screenshot 0.2

namespace eval ::screenshot {
	
	namespace export screenshot

	# -- resizeHandle
	# --------------------------------------------------------------------
	# http://wiki.tcl.tk/3350, Thanks to:
	# George Peter Staplin: A resize handle is that funky thing usually
	# on the bottom right of a window that you can use to resize a window.
	# --------------------------------------------------------------------

	image create bitmap resizeHandle:image -data {
		#define resizeHandle_width 25
		#define resizeHandle_height 25
		static unsigned char resizeHandle_bits[] = {
			0x40, 0x10, 0x04, 0x01, 0x20, 0x08, 0x82, 0x00, 0x10, 0x04, 0x41, 0x00,
			0x08, 0x82, 0x20, 0x00, 0x04, 0x41, 0x10, 0x00, 0x82, 0x20, 0x08, 0x00,
			0x41, 0x10, 0x04, 0x01, 0x20, 0x08, 0x82, 0x00, 0x10, 0x04, 0x41, 0x00,
			0x08, 0x82, 0x20, 0x00, 0x04, 0x41, 0x10, 0x00, 0x82, 0x20, 0x08, 0x00,
			0x41, 0x10, 0x04, 0x01, 0x20, 0x08, 0x82, 0x00, 0x10, 0x04, 0x41, 0x00,
			0x08, 0x82, 0x20, 0x00, 0x04, 0x41, 0x10, 0x00, 0x82, 0x20, 0x08, 0x00,
			0x41, 0x10, 0x04, 0x01, 0x20, 0x08, 0x82, 0x00, 0x10, 0x04, 0x41, 0x00,
			0x08, 0x82, 0x20, 0x00, 0x04, 0x41, 0x10, 0x00, 0x82, 0x20, 0x08, 0x00,
			0x41, 0x10, 0x04, 0x00};
	}
	
	proc Event_ButtonPress1 {win resizeWin X Y} {
		upvar #0 _resizeHandle$win ar
		set ar(startX) $X
		set ar(startY) $Y
		set ar(minWidth) [image width resizeHandle:image]
		set ar(minHeight) [image height resizeHandle:image]
		set ar(resizeWinX) [winfo x $resizeWin]
		set ar(resizeWinY) [winfo y $resizeWin]
	}
	
	proc Event_B1Motion {win resizeWin internal X Y} {
		upvar #0 _resizeHandle$win ar
		
		set xDiff [expr {$X - $ar(startX)}]
		set yDiff [expr {$Y - $ar(startY)}]
		
		set oldWidth [winfo width $resizeWin]
		set oldHeight [winfo height $resizeWin]
		
		set newWidth [expr {$oldWidth + $xDiff}]
		set newHeight [expr {$oldHeight + $yDiff}]
		
		if {$newWidth < $ar(minWidth) || $newHeight < $ar(minHeight)} {
			return
		}
		
		if {$internal == 0} {
			set newX "+$ar(resizeWinX)"
			set newY "+$ar(resizeWinY)"
			
			wm geometry $resizeWin ${newWidth}x${newHeight}${newX}${newY}
		} else {
			place $resizeWin -width $newWidth -height $newHeight -x $ar(resizeWinX) -y $ar(resizeWinY)
		}
		
		set ar(startX) $X
		set ar(startY) $Y
	}
	
	proc Event_Destroy {win} {
		upvar #0 _resizeHandle$win ar
		# catch because this may not be set
		catch {array unset ar}
	}
	
	proc resizeHandle {win resizeWin args} {
		eval label [concat $win $args -image resizeHandle:image]
		
		bind $win <ButtonPress-1> "[namespace current]::Event_ButtonPress1 $win $resizeWin %X %Y"
		bind $win <B1-Motion> "[namespace current]::Event_B1Motion $win $resizeWin 0 %X %Y"
		bind $win <Destroy> "[namespace current]::Event_Destroy $win"
		return $win
	}

	# --------------------------------------------------------------------
	# --------------------------------------------------------------------
	
	# this is a tk-like wrapper around the class,
	# so that object creation works like other Tk widgets
	
	proc screenshot {path args} {
		set obj [ScreenShot create tmp $path {*}$args]
		rename $obj ::$path
		return $path
	}
	
	# a canvas based object
	oo::class create ScreenShot {
		
		constructor {path args} {
			my variable wcanvas
			my variable woptions
			my variable width
			my variable height
			my variable measure
			my variable shade

			my variable edge
			my variable drag
			my variable curdim
			
			my variable timeout
			my variable timeout_max
			my variable timeout_incr
			
			set timeout 0
			set timeout_max 16
			set timeout_incr 2
			
			array set woptions {
				-foreground	black
				-background LightYellow
				-font {Helvetica 14}
				-interval {10 50 100}
				-sizes {4 8 12}
				-showvalues	1
				-outline 1
				-grid 1
				-measure pixels
				-zoom 1
				-showgeometry 1
				-alpha 0.7
				-topmost 1
				-screenshotcommand ""
				-screenshotcancelcommand ""
			}
			
			array set shade {
				small gray medium gray large gray
			}
			
			array set measure {
				what ""
				valid {pixels points inches mm cm}
				cm c mm m inches i points p pixels ""
			}
			
			set width 0
			set height 0

			array set edge {
				at 0
				left   1
				right  2
				top    3
				bottom 4
			}

			array set drag {}
			array set curdim {x 0 y 0 w 0 h 0}
			
			# --------------------------------
			ttk::frame $path -class ScreenShot
			# --------------------------------

			# for the screenshot window, depending on the os-spcific window manager,
			# we'd like to have a semi-transparent window, which is on the very top of
			# all the windows stack and which is borderless (wm overrideredirect ...)
			#
			set t [winfo toplevel $path]
			
			# bug fix for linux:
			if { $::tcl_platform(os) == "Linux" } {
				wm withdraw $t
			}

			catch {
				wm attributes $t -topmost 1
				wm overrideredirect $t 1
			}

			pack [frame $path.f] -side bottom -anchor e
			pack [::screenshot::resizeHandle $path.f.label $t] -side left
			
			canvas $path.c \
				-width 800 -height 600 -relief flat -bd 0 \
				-background white -highlightthickness 0

			set wcanvas $path.c
			pack $wcanvas -fill both -expand true
			
			bind $wcanvas <Configure>     "[namespace code {my Resize}] %W %w %h"
			bind $wcanvas <ButtonPress-1> "[namespace code {my DragStart}] %W %X %Y"
			bind $wcanvas <B1-Motion>     "[namespace code {my PerformDrag}] %W %X %Y"
			bind $wcanvas <Motion>        "[namespace code {my EdgeCheck}] %W %x %y"

			bind $wcanvas <Double-ButtonPress-1> "[namespace code {my ScreenShotCmd}]"
			bind $wcanvas <KeyPress-Return> "[namespace code {my ScreenShotCmd}]"

			focus -force $wcanvas
		
			my AddMenu $wcanvas
			
			# $wcanvas xview moveto 0 ;	$wcanvas yview moveto 0
			
			# we must rename the widget command
			# since it clashes with the object being created
			
			set widget ${path}_
			rename $path $widget
	
			# start with default configuration
			foreach opt_name [array names woptions] {
				my configure $opt_name $woptions($opt_name)
			}

			
			# and configure custom arguments
			my configure {*}$args
			
			# bug fix for linux:
			if { $::tcl_platform(os) == "Linux" } {
				after 10 "wm deiconify $t; wm attributes $t -alpha $woptions(-alpha)"
			}
		}
		
		destructor {
			set w [namespace tail [self]]
			catch {bind $w <Destroy> {}}
			catch {destroy $w}
		}
		
		method cget { {opt "" }  } {
			my variable wcanvas
			my variable woptions
			
			if { [string length $opt] == 0 } {
				return [array get woptions]
			}
			if { [info exists woptions($opt) ] } {
				return $woptions($opt)
			}
			return [$wcanvas cget $opt]
		}
		
		method configure { args } {
			my variable wcanvas
			my variable woptions
			my variable measure
			my variable curdim

			if {[llength $args] == 0}  {
				
				# return all canvas options
				set opt_list [$wcanvas configure]
				
				# as well as all custom options
				foreach xopt [array get woptions] {
					lappend opt_list $xopt
				}
				return $opt_list
				
			} elseif {[llength $args] == 1}  {
				
				# return configuration value for this option
				set opt $args
				if { [info exists woptions($opt) ] } {
					return $woptions($opt)
				}
				return [$wcanvas cget $opt]
			}
			
			# error checking
			if {[expr {[llength $args]%2}] == 1}  {
				return -code error "value for \"[lindex $args end]\" missing"
			}
			
			# overwrite with new value and
			# process all configuration options...
			#
			array set opts $args
			
			foreach opt_name [array names opts] {
				set opt_value $opts($opt_name)

				# overwrite with new value
				if { [info exists woptions($opt_name)] } {
					set woptions($opt_name) $opt_value
				}
				
				# some options need action from the widgets side
				switch -- $opt_name {
					-font {}
					-sizes - -showvalues - -outline - -grid - -zoom {
						my Redraw
					}
					-foreground {
						my ReShade
						my Redraw
					}
					-measure {
						if {[set idx [lsearch -glob $measure(valid) $opt_value*]] == -1} {
							return -code error "invalid $option value \"$value\":\
									must be one of [join $measure(valid) {, }]"
						}
						set value [lindex $measure(valid) $idx]
						set measure(what) $measure($value)
						set woptions(-measure) $value
						my Redraw
					}
					-interval {
						set dir 1
						set newint {}
						foreach i $woptions(-interval) {
							if {$dir < 0} {
								lappend newint [expr {$i/2.0}]
							} else {
								lappend newint [expr {$i*2.0}]
							}
						}
						set woptions(-interval) $newint
						my Redraw
					}
					-showgeometry {
						if {![string is boolean -strict $opt_value]} {
							return -code error "invalid $option value \"$opt_value\":\
								must be a valid boolean"
						}

						$wcanvas delete geoinfo

						if {$opt_value} {
							set x 20
							set y 20
							foreach d {x y w h} {

								set w $wcanvas._$d
								catch { destroy $w }

								entry $w -borderwidth 1 -highlightthickness 1 -width 4 \
									-textvar [namespace current]::curdim($d) \
									-bg White

								$wcanvas create window $x $y -window $w -tags geoinfo
								
								bind $w <Return> "[namespace code {my PlaceCmd}]"

								# avoid toplevel bindings
								bindtags $w [list $w Entry all]
								incr x [winfo reqwidth $w]
							}
						}
					}
					-alpha {
						wm attributes [winfo toplevel $wcanvas] -alpha $opt_value
					}
					-topmost {
						wm attributes [winfo toplevel $wcanvas] -topmost $opt_value
					}
					-geometry {
						wm geometry [winfo toplevel $wcanvas] $opt_value
					}
					-screenshotcommand {
						set woptions(-screenshotcommand) $opt_value
					}
					-screenshotcancelcommand {
						set woptions(-screenshotcancelcommand) $opt_value
					}
					default {
						# if the configure option wasn't one of our special one's,
						# pass control over to the original canvas widget
						#
						if {[catch {$wcanvas configure $opt_name $opt_value} result]} {
							return -code error $result
						}
					}
				}
			}
		}

		method display {} {
			my variable wcanvas
			set win [winfo toplevel $wcanvas]
			wm deiconify $win
			raise $win
			focus $win
		}

		method hide {} {
			my variable wcanvas
			set win [winfo toplevel $wcanvas]
			wm withdraw $win
			
			# wait a bit so that the pop-up menu
			# has time to disappear...
			# ----------------------------------
			after 400 {set ::_wait_flag 1}
			vwait ::_wait_flag
			# ----------------------------------
		}

		method unknown {method args} {
			my variable wcanvas
			
			# if the command wasn't one of our special one's,
			# pass control over to the original canvas widget
			#
			if {[catch {$wcanvas $method {*}$args} result]} {
				return -code error $result
			}
			return $result
		}
	
		method getgeometry {} {
			my variable curdim
			return [list $curdim(x) $curdim(y) $curdim(w) $curdim(h)]
		}
	
		method PlaceCmd {} {
			my variable wcanvas
			my variable curdim

			set win [winfo toplevel $wcanvas]
			wm geometry $win $curdim(w)x$curdim(h)+$curdim(x)+$curdim(y)
		}
		

		method ReShade {} {
			my variable wcanvas
			my variable woptions
			my variable shade
			
			set bg [$wcanvas cget -bg]
			set fg $woptions(-foreground)
			set shade(small)  [my Shade $bg $fg 0.15]
			set shade(medium) [my Shade $bg $fg 0.4]
			set shade(large)  [my Shade $bg $fg 0.8]
		}
		
		method Redraw {} {
			my variable wcanvas
			my variable woptions
			my variable width
			my variable height
			my variable measure
			
			$wcanvas delete ruler
			
			set width  [winfo width $wcanvas]
			set height [winfo height $wcanvas]
			
			my Redraw_x
			my Redraw_y
			
			if {$woptions(-outline) || $woptions(-grid)} {
				
				if {[tk windowingsystem] eq "aqua"} {
					# Aqua has an odd off-by-one drawing
					set coords [list 0 0 $width $height]
				} else {
					set coords [list 0 0 [expr {$width-1}] [expr {$height-1}]]
				}
				$wcanvas create rect $coords \
						-width 1 \
						-outline $woptions(-foreground) \
						-tags [list ruler outline]
			}
			
			if {$woptions(-showvalues) && $height > 20} {
				
				if {$measure(what) ne ""} {
					set m   [winfo fpixels $wcanvas 1$measure(what)]
					set txt "[format %.2f [expr {$width / $m}]] x\
							[format %.2f [expr {$height / $m}]] $woptions(-measure)"
				} else {
					set txt "$width x $height"
				}
				if {$woptions(-zoom) > 1} {
					append txt " (x$woptions(-zoom))"
				}
				$wcanvas create text 15 [expr {$height/2.}] \
						-text $txt \
						-anchor w -tags [list ruler value label] \
						-fill $woptions(-foreground)
			}
			$wcanvas raise large
			$wcanvas raise value
		}
		
		method Redraw_x {} {
			my variable wcanvas
			my variable woptions
			my variable width
			my variable height
			my variable measure
			my variable shade
			
			foreach {sms meds lgs} $woptions(-sizes) { break }
			foreach {smi medi lgi} $woptions(-interval) { break }
			for {set x 0} {$x < $width} {set x [expr {$x + $smi}]} {
				set dx [winfo fpixels $wcanvas \
						[expr {$x * $woptions(-zoom)}]$measure(what)]
				if {fmod($x, $lgi) == 0.0} {
					# draw large tick
					set h $lgs
					set tags [list ruler tick large]
					if {$x && $woptions(-showvalues) && $height > $lgs} {
						$wcanvas create text [expr {$dx+1}] $h -anchor nw \
								-text [format %g $x]$measure(what) \
								-tags [list ruler value]
					}
					set fill $shade(large)
				} elseif {fmod($x, $medi) == 0.0} {
					set h $meds
					set tags [list ruler tick medium]
					set fill $shade(medium)
				} else {
					set h $sms
					set tags [list ruler tick small]
					set fill $shade(small)
				}
				if {$woptions(-grid)} {
					$wcanvas create line $dx 0 $dx $height -width 1 -tags $tags \
							-fill $fill
				} else {
					$wcanvas create line $dx 0 $dx $h -width 1 -tags $tags \
							-fill $woptions(-foreground)
					$wcanvas create line $dx $height $dx [expr {$height - $h}] \
							-width 1 -tags $tags -fill $woptions(-foreground)
				}
			}
		}
		
		method Redraw_y {} {
			my variable wcanvas
			my variable woptions
			my variable width
			my variable height
			my variable measure
			my variable shade
			
			foreach {sms meds lgs} $woptions(-sizes) { break }
			foreach {smi medi lgi} $woptions(-interval) { break }
			for {set y 0} {$y < $height} {set y [expr {$y + $smi}]} {
				set dy [winfo fpixels $wcanvas \
						[expr {$y * $woptions(-zoom)}]$measure(what)]
				if {fmod($y, $lgi) == 0.0} {
					# draw large tick
					set w $lgs
					set tags [list ruler tick large]
					if {$y && $woptions(-showvalues) && $width > $lgs} {
						$wcanvas create text $w [expr {$dy+1}] -anchor nw \
								-text [format %g $y]$measure(what) \
								-tags [list ruler value]
					}
					set fill $shade(large)
				} elseif {fmod($y, $medi) == 0.0} {
					set w $meds
					set tags [list ruler tick medium]
					set fill $shade(medium)
				} else {
					set w $sms
					set tags [list ruler tick small]
					set fill $shade(small)
				}
				if {$woptions(-grid)} {
					$wcanvas create line 0 $dy $width $dy -width 1 -tags $tags \
							-fill $fill
				} else {
					$wcanvas create line 0 $dy $w $dy -width 1 -tags $tags \
							-fill $woptions(-foreground)
					$wcanvas create line $width $dy [expr {$width - $w}] $dy \
							-width 1 -tags $tags -fill $woptions(-foreground)
				}
			}
		}
		
		method Resize {W w h} {
			my variable wcanvas
			my variable curdim
			
			set curdim(w) $w
			set curdim(h) $h
			
			my Redraw
		}
		
		method Shade {orig dest frac} {
			my variable wcanvas
			
			if {$frac >= 1.0} {return $dest} elseif {$frac <= 0.0} {return $orig}
			foreach {oR oG oB} [winfo rgb $wcanvas $orig] \
					{dR dG dB} [winfo rgb $wcanvas $dest] {
						set color [format "\#%02x%02x%02x" \
						[expr {int($oR+double($dR-$oR)*$frac)}] \
						[expr {int($oG+double($dG-$oG)*$frac)}] \
						[expr {int($oB+double($dB-$oB)*$frac)}]]
						return $color
					}
		}
		
		method EdgeCheck {w x y} {
			my variable edge
			
			set CHKWIDTH 8
			set edge(at) 0

			set cursor ""
			if {$x < $CHKWIDTH || $x > ([winfo width $w] - $CHKWIDTH)} {
				set cursor sb_h_double_arrow
				set edge(at) [expr {$x < $CHKWIDTH ? $edge(left) : $edge(right)}]
			} elseif {$y < $CHKWIDTH || $y > ([winfo height $w] - $CHKWIDTH)} {
				set cursor sb_v_double_arrow
				set edge(at) [expr {$y < $CHKWIDTH ? $edge(top) : $edge(bottom)}]
			}
			$w configure -cursor $cursor
		}
		
		method DragStart {w X Y} {
			my variable drag
		
			set drag(X) [expr {$X - [winfo rootx $w]}]
			set drag(Y) [expr {$Y - [winfo rooty $w]}]
			set drag(w) [winfo width $w]
			set drag(h) [winfo height $w]
			my EdgeCheck $w $drag(X) $drag(Y)
			
			raise $w
			focus $w
		}
		
		method PerformDrag {w X Y} {
			my variable edge
			my variable drag
			my variable curdim
			
			set curdim(x) [winfo rootx $w]
			set curdim(y) [winfo rooty $w]
			
			set win [winfo toplevel $w]
			
			if {$edge(at) == 0} {
				set dx [expr {$X - $drag(X)}]
				set dy [expr {$Y - $drag(Y)}]
				wm geometry $win +$dx+$dy
			} elseif {$edge(at) == $edge(left)} {
				# need to handle moving root - currently just moves
				set dx [expr {$X - $drag(X)}]
				set dy [expr {$Y - $drag(Y)}]
				wm geometry $win +$dx+$dy
			} elseif {$edge(at) == $edge(right)} {
				set relx   [expr {$X - [winfo rootx $win]}]
				set width  [expr {$relx - $drag(X) + $drag(w)}]
				set height $drag(h)
				if {$width > 5} {
					wm geometry $win ${width}x${height}
				}
			} elseif {$edge(at) == $edge(top)} {
				# need to handle moving root - currently just moves
				set dx [expr {$X - $drag(X)}]
				set dy [expr {$Y - $drag(Y)}]
				wm geometry $win +$dx+$dy
			} elseif {$edge(at) == $edge(bottom)} {
				set rely   [expr {$Y - [winfo rooty $win]}]
				set width  $drag(w)
				set height [expr {$rely - $drag(Y) + $drag(h)}]
				if {$height > 5} {
					wm geometry $win ${width}x${height}
				}
			}
		}

		# allows to add additional menu entries once the screenshot widget
		# has been initialized 
		method getmenuwidget {} {
			my variable wmenu
			return $wmenu
		}
		
		method AddMenu {wcanvas} {
			my variable woptions
			my variable timeout
			my variable timeout_max
			my variable wmenu
		
			if {[tk windowingsystem] eq "aqua"} {
				set CTRL    "Command-"
				set CONTROL Command
			} else {
				set CTRL    CTRL+
				set CONTROL Control
			}
		
			set m $wcanvas.menu
			
			menu $m -tearoff 1

			set m0 [menu $m.extras -tearoff 0]
			set wmenu $m0

			$m add cascade -label "Program Info..." -menu $m0 -underline 0
			
			$m add separator
			$m add command \
				-label "Options:" \
				-state disabled

			if {[tk windowingsystem] ne "x11"} {
				$m add checkbutton -label "Keep on Top" \
					-underline 8 -accelerator "t" \
					-variable [namespace current]::woptions(-topmost) \
					-command "[namespace code {my configure}] -topmost $[namespace current]::woptions(-topmost)"
			
				bind $wcanvas <Key-t> [list $m invoke "Keep on Top"]
			}

			$m add checkbutton -label "Show Grid" \
				-accelerator "g" -underline 5 \
				-variable [namespace current]::woptions(-grid) \
				-command "[namespace code {my configure}] -grid $[namespace current]::woptions(-grid)"

			bind $wcanvas <Key-g> [list $m invoke "Show Grid"]
		
			set m1 [menu $m.opacity -tearoff 0]
			$m add cascade -label "Opacity" -menu $m1 -underline 0
			for {set i 10} {$i <= 100} {incr i 10} {
				set aval [expr {$i/100.}]
				$m1 add radiobutton -label "${i}%" \
					-variable [namespace current]::woptions(-alpha) \
					-value $aval \
					-command "[namespace code {my configure}] -alpha $[namespace current]::woptions(-alpha)"
			}

			$m add separator

			$m add command \
				-label "Screenshot now" \
				-accelerator ${CTRL}s \
				-underline 7 \
				-command "[namespace code {my ScreenShotCmd}]" \
				-background $woptions(-background)

			$m add command \
				-label "Screenshot with mouse:" \
				-accelerator {DOUBLE-CLICK-1} \
				-state disabled

			set m2 [menu $m.timeout -tearoff 0]
			$m add cascade -label "Screenshot with Timeout..." -menu $m2 -underline 0
			for {set i 0} {$i <= $timeout_max} {incr i 4} {
				$m2 add radiobutton -label "${i} sec" \
					-variable [namespace current]::timeout \
					-value $i \
					-command "[namespace code {my ScreenShotCmd}]"
			}
				
			$m add separator
			$m add command \
				-label "Close Window" \
				-accelerator "ESC" \
				-command "[namespace code {my ExitCmd}]"

			bind $wcanvas <Escape> "[namespace code {my ExitCmd}]"
			bind $wcanvas <Double-ButtonPress-1> "[namespace code {my ScreenShotCmd}]"

			# menu invoke can also be used,
			# make sure that the invoke command gets exactly the label string
			#
			bind $wcanvas <$CONTROL-s> [list $m invoke "Screenshot now..."]			

			if {[tk windowingsystem] eq "aqua"} {
				# aqua switches 2 and 3 ...
				bind $wcanvas <Control-ButtonPress-1> [list tk_popup $m %X %Y]
				bind $wcanvas <ButtonPress-2> [list tk_popup $m %X %Y]
			} else {
				bind $wcanvas <ButtonPress-3> [list tk_popup $m %X %Y]
			}
		
		}
		
		# wait a few msec's ...
		method Wait {msec} {
			set ::wait 0; after $msec {set ::wait 1}; vwait ::wait					
		}

		method ScreenShotCmd {} {
			my variable woptions
			my variable wcanvas
			my variable curdim
			my variable timeout
			my variable timeout_max
			my variable timeout_incr
			
			# perform screenshot after timeout ? ...
			if {$timeout != 0} {
			
				# add text to the canvas
				set textfont {Helvetica 24}
				set txtitem [$wcanvas create text 50 50 \
								-text "Timeout: ${timeout} sec..." \
								-width 440 -anchor nw -font $textfont -justify left\
								-fill "DarkBlue"]
				$wcanvas addtag text withtag $txtitem
				
				# text animation loop...
				for {set i $timeout} {$i != 0} {incr i [expr {$timeout_incr * -1}]} {
					$wcanvas itemconfigure $txtitem -fill "Orange"
					$wcanvas itemconfigure $txtitem -text "Timeout: ${i} sec..."
					
					my Wait [expr {$timeout_incr * 1000}]
				}
			}

			if { [catch {package require treectrl}] != 0 ||
								[llength [info commands loupe]] == 0 } {
				return -code error "tktreectrl loupe command is not available."
			}

			my hide

			set capture_img [image create photo \
									-width $curdim(w) -height $curdim(h)]
			set zoom 1
			set loupe_ctr_x [expr {$curdim(x) + $curdim(w) / 2}]
			set loupe_ctr_y [expr {$curdim(y) + $curdim(h) / 2}]

			# ----------------------------------------------------------------------------
			# a delay is required, otherwise the image won't get copied
			# ----------------------------------------------------------------------------
			after idle \
				"loupe $capture_img $loupe_ctr_x $loupe_ctr_y $curdim(w) $curdim(h) $zoom"
			set ::_vwait 0; after idle {set ::_vwait 1}; vwait ::_vwait
			# ----------------------------------------------------------------------------

			# -only for development-
			# $wcanvas create image 0 0 -anchor nw -image $capture_img
			# my display
			# puts [$capture_img data -format "png"]
			# $capture_img write "capture_img.png" -format "png"

			# evaluate the given command in parent namespace with
			# the capture image as argument to the function:
			#
			if {$woptions(-screenshotcommand) != ""} {
				uplevel $woptions(-screenshotcommand) $capture_img \
							[wm geometry [winfo toplevel $wcanvas]] \
							$woptions(-grid) $woptions(-alpha)
			}
		}
		
		method ExitCmd {} {
			my variable woptions
			my variable wcanvas
			
			set win [winfo toplevel $wcanvas]
			set geometry [wm geometry $win]
			destroy $win

			# evaluate the given command in parent namespace
			#
			if {$woptions(-screenshotcancelcommand) != ""} {
				uplevel $woptions(-screenshotcancelcommand) \
							$geometry $woptions(-grid) $woptions(-alpha)
			}
		}
	}
	
}

Sourcecode of screenshot_test.tcl...

# ---------
# demo code
# ---------


# where to find the required library packages,
# auto_path usually needs to be modified to fit your specific environment:
#
set dir [file dirname [info script]]
lappend auto_path [file join $dir "."]
# lappend auto_path [file join $dir "../../tksqlite-0.5.13-modified.vfs/lib"]


package require Tk
package require TclOO
package require treectrl
package require Img

package require screenshot

# http://wiki.tcl.tk/10504

# DKF: Here's a version (no alpha channel handling) which goes a bit faster.
# It also supports an optional third argument for those times when you want to
# supply a target image.

# -works- but slow!

proc Shrink3 {Image coef {TargetImage {}}} {
	# check coef
	if {$coef > 1.0} {
		error "bad coef \"$coef\": should not be greater than 1.0"
	}
	# get the old image content
	set Width [image width $Image]
	set Height [image height $Image]
	if {$Width == 0 || $Height == 0} {
		error "bad image"
	}
	if {$TargetImage eq ""} {
		# create new image
		set image [image create photo]
	} else {
		set image $TargetImage
	}
	if {abs($coef - 1.0) < 1.e-4} {
		$image copy $Image
		return $image
	}
	set Factor [expr {double($Width)*$Height}]
	# Extract the data from the source - experiment indicates that this is the fastest way
	foreach row [$Image data] {
		set rdata {}
		foreach pixel $row {
			lappend rdata [scan $pixel "#%2x%2x%2x"]
		}
		lappend DATA $rdata
	}
	# compute the new image content
	set width [expr {round($Width * $coef)}]
	set height [expr {round($Height * $coef)}]
	set ey 0
	set Y2 0
	set cy2 $height
	for {set y 0} {$y < $height} {incr y} {
		# Y1 is the top coordinate in the old image
		set Y1 $Y2
		set cy1 [expr {$height - $cy2}]
		incr ey $Height
		set Y2 [expr {$ey / $height}]
		set cy2 [expr {$ey % $height}]
		if {$Y1 == $Y2} {
			set cy1 $cy2
		}
		set ex 0
		set X2 0
		set cx2 $width
		set row {}
		for {set x 0} {$x < $width} {incr x} {
			set X1 $X2
			set cx1 [expr {$width - $cx2}]
			incr ex $Width
			set X2 [expr {$ex / $width}]
			set cx2 [expr {$ex % $width}]
			if {$X1 == $X2} {
				set cx1 $cx2
			}
			# compute pixel
			set r 0.0
			set g 0.0
			set b 0.0
			for {set Y $Y1} {$Y <= $Y2} {incr Y} {
				# compute y coef
				if {$Y == $Y1} {
					if {$cy1 == 0} continue
					set cy [expr {$cy1>$Height ? $Height : $cy1}]
				} elseif {$Y == $Y2} {
					if {$cy2 == 0} continue
					set cy [expr {$cy2>$Height ? $Height : $cy2}]
				} else {
					set cy $height
				}
				for {set X $X1} {$X <= $X2} {incr X} {
					# compute x coef
					if {$X == $X1} {
						if {$cx1 == 0} continue
						set cx [expr {$cx1>$Width ? $Width : $cx1}]
					} elseif {$X == $X2} {
						if {$cx2 == 0} continue
						set cx [expr {$cx2>$Width ? $Width : $cx2}]
					} else {
						set cx $width
					}
					# weight each initial pixel by cx & cy
					set cxy [expr {$cx * $cy / $Factor}]
					set pixel [lindex $DATA $Y $X]
					set r [expr {$r+([lindex $pixel 0] * $cxy)}]
					set g [expr {$g+([lindex $pixel 1] * $cxy)}]
					set b [expr {$b+([lindex $pixel 2] * $cxy)}]
				}
			}
			lappend row [format "#%02x%02x%02x" \
					[expr {$r>255.0 ? 255 : round($r)}] \
					[expr {$g>255.0 ? 255 : round($g)}] \
					[expr {$b>255.0 ? 255 : round($b)}]]
		}
		lappend data $row
	}
	# fill the new image
	$image blank
	$image put $data
	# return the new image
	return $image
}


proc ScaleImage {img1 targetwidth} {

	set w [image width $img1]
	set ratio [expr {$targetwidth / ($w * 1.0)}]
	set img2 [image create photo]

	if {$ratio >= 1} {
		set f [expr int($ratio)]
		$img2 copy $img1 -zoom $f $f

	} else {
		set f [expr round(1.0 / $ratio)]
		
		# a.) Img package (bad quality):
		$img2 copy $img1 -subsample $f $f

		# test as well the following: 
		# $img2 copy $img1 -shrink
		
		# b.) with procedure (slightly better quality, but slow):
		#     http://wiki.tcl.tk/10504
		# set img2 [Shrink3 $img1 $ratio]
	}

	image delete $img1
	return $img2
}


proc SaveScreenShot {wparent capture_img} {

	# finally, write image to file and we are done...
	set filetypes {
		{"All Image Files" {.gif .png .jpg}}
		{"PNG Images" .png}
	}

	set re {\.(gif|png)$}
	set LASTDIR [pwd]
			
	set file [tk_getSaveFile \
		-parent $wparent -title "Save Image to File" \
		-initialdir $LASTDIR -filetypes $filetypes]
			
	if {$file ne ""} {
			
		if {![regexp -nocase $re $file -> ext]} {
			set ext "png"
			append file ".${ext}"
		}
		
		# -test-
		set scaled_img [ScaleImage $capture_img 1200]

		if {[catch {$scaled_img write $file \
					-format [string tolower $ext]} err]} {
						
			tk_messageBox -title "Error Writing File" \
				-parent $wparent -icon error -type ok \
				-message "Error writing to file \"$file\":\n$err"
		}
		
		# clear some memory:
		image delete $scaled_img
	}
}



set dev_mode 1

if { $dev_mode } {
	catch {
		console show
		console eval {wm protocol . WM_DELETE_WINDOW {exit 0}}
	}
}

wm withdraw .
set t [toplevel .t]

wm geometry $t "+50+50"

screenshot::screenshot $t.scrnshot \
		-background LightYellow -foreground DarkGreen \
		-alpha 0.5 \
		-width 800 -height 600 \
		-screenshotcommand "SaveScreenShot $t"

		
# default values:
# -showgeometry 1
# -grid 1 -showvalues 1
# -measure pixels
# ...

pack $t.scrnshot -expand true -fill both