Purpose:
A TclOO class which implements a convenient 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. The code can be used nearly "stand alone" but might be useful for various other application, e.g. like a note taken application, etc...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.- 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 convenient 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 aforementioned code is available in tklib.
# -----------------------------------------------------------------------------
# Revision history:
# 18-01-04: J.Oberdorfer, Initial release
# XX-XX-XX: Comments and improvements whatsoever are very welcome.
# -----------------------------------------------------------------------------
package require Tk
package require TclOO
package require treectrl
package require Img
package provide screenshot 0.1
namespace eval ::screenshot {
namespace export screenshot
# 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
array set woptions {
-foreground black
-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
}
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-specific 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]
catch {
wm attributes $t -topmost 1
wm overrideredirect $t 1
}
canvas $path.c \
-width 600 -height 300 \
-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"
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
}
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 Orange
$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
}
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
}
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 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 edge(at) 0
set cursor ""
if {$x < 4 || $x > ([winfo width $w] - 4)} {
set cursor sb_h_double_arrow
set edge(at) [expr {$x < 4 ? $edge(left) : $edge(right)}]
} elseif {$y < 4 || $y > ([winfo height $w] - 4)} {
set cursor sb_v_double_arrow
set edge(at) [expr {$y < 4 ? $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}
}
}
}
method AddMenu {wcanvas} {
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 0
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 "d" -underline 8 \
-variable [namespace current]::woptions(-grid) \
-command "[namespace code {my configure}] -grid $[namespace current]::woptions(-grid)"
bind $wcanvas <Key-d> [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 "Create Screen-shot..." \
-accelerator ${CTRL}s \
-underline 7 \
-command "[namespace code {my ScreenShotCmd}]" \
-background "LightYellow"
bind $wcanvas <$CONTROL-s> [list $m invoke "Create Screen-shot..."]
$m add separator
$m add command -label "Exit" \
-accelerator ${CTRL}q -underline 1 \
-command { exit 0 } \
bind $wcanvas <$CONTROL-q> { exit 0 }
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]
}
}
method ScreenShotCmd {} {
my variable wcanvas
my variable curdim
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}]
# ----------------------------------------------------------------------------
after idle \
"loupe $capture_img $loupe_ctr_x $loupe_ctr_y $curdim(w) $curdim(h) $zoom"
# ----------------------------------------------------------------------------
# -only for development-
# $wcanvas create image 0 0 -anchor nw -image $capture_img
# my display
# finally, write image to file and we are done...
set filetypes {
{"All Image Files" {.gif .png}}
{"PNG Images" .png}
}
set re {\.(gif|png)$}
set LASTDIR [pwd]
set file [tk_getSaveFile \
-parent $wcanvas -title "Save Image to File" \
-initialdir $LASTDIR -filetypes $filetypes]
if {$file ne ""} {
if {![regexp -nocase $re $file -> ext]} {
set ext "png"
append file ".${ext}"
}
if {[catch {$capture_img write $file \
-format [string tolower $ext]} err]} {
tk_messageBox -title "Error Writing File" \
-parent $wcanvas -icon error -type ok \
-message "Error writing to file \"$file\":\n$err"
}
}
}
}
}
- pkgIndex.tcl
if { ![package vsatisfies [package provide Tcl] 8.6] } { return }
package ifneeded screenshot 0.1 [list source [file join $dir screenshot.tcl]]
- 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
set dev_mode 0
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 Green
# default values:
# -showgeometry 1
# -grid 1 -showvalues 1
# -measure pixels
# ...
pack $t.scrnshot -expand true -fill both
