**Snipping Tool**
'''[saito] - 2023-02-17'''
Do you miss the little snipping utility from Windows 10? MS has removed it from Windows 11.
But no worries - you can use my version:
Just source it and play with the demo when it pops up:
%Available tkscommanit_ds aremo:
* tksnip : this command will create a new snip
* tksnip img : this will return the result in the named image given as argument
* tksnip_demo : this will pop up the demo app
======
package require Tk
package require treectrl
after 2000 tksnitp_demo
proc tksnitp_demo {} {
wm minsize . 400 400
wm geom . 900x600
image create photo testimage
button .b -text "Take a snip" -command [list tksnip testimage]
button .q -text "Quit" -command [list exit]
button .l -anchor sw -bd 0 \
-text "Please wait until screen flashes. Select a screen region with your mouse. When you release, your image will be displayed."
canvas .c -bd 2 -relief ridge -width 2000 -height 2000 \
-scrollregion {0 0 2000 2000} \
-xscrollcommand [list .x set] -yscrollcommand [list .y set]
scrollbar .x -orient horizontal -command [list .c xview]
scrollbar .y -orient vertical -command [list .c yview]
.c create image 0 0 -image testimage -anchor nw
grid .c -row 1 -column 1 -sticky news -columnspan 2
grid .x -row 2 -column 1 -sticky ew -columnspan 2
grid .y -row 1 -column 3 -sticky ns
grid .b -row 3 -column 1 -sticky ns
grid .q -row 3 -column 2 -sticky ns
grid .l -row 4 -column 1 -sticky news -columnspan 2
grid rowconfigure . 1 -weight 1
grid rowconfigure . 2 -weight 0
grid rowconfigure . 3 -weight 0
grid columnconfigure . 1 -weight 1
grid columnconfigure . 2 -weight 1
grid columnconfigure . 3 -weight 0
}
################################
proc tksnip {{dest_img {}}} {
global tksnip
incr tksnip(id)
set seq $tksnip(id)
set win ".snip${seq}"
if {[winfo exists $win]} {
### id not unique
return ""
}
### take the screenshot of the full screen
set w [winfo screenwidth .]
set h [winfo screenheight .]
lassign [tksnip_loupe 0 0 $w $h] bg_img x y w h
### use overrideredirect to pretend it is full screen
### and change its alpha level
toplevel $win
wm attributes $win -alpha 0.4
wm geometry $win ${w}x${h}+0+0
wm overrideredirect $win 1
### canvas
set can $win.c
canvas $can -width $w -height $h -bd 0 -relief flat
$win.c create image 0 0 -image $bg_img -anchor nw
pack $can -fill both -expand 1
### initialize
set tksnip($seq,topwin) $win
set tksnip($seq,canvas) $can
set tksnip($seq,full_img) $bg_img
set tksnip($seq,dest_img) $dest_img
set tksnip($seq,final_img) ""
set tksnip($seq,coords) [list]
set tksnip($seq,region) {}
set tksnip($seq,afterID) {}
set tksnip($seq,finito) ""
### canvas bindings
bind $win <Button-1> [list tksnip_button1 $seq {%x} {%y}]
bind $win <B1-Motion> [list tksnip_motion $seq {%x} {%y}]
bind $win <ButtonRelease-1> [list tksnip_release1 $seq {%x} {%y}]
bind $win <Double-Button-1> [list tksnip_done $seq]
bind $win <Escape> [list tksnip_done $seq]
bind $can <Button-1> [list tksnip_button1 $seq {%x} {%y}]
bind $can <B1-Motion> [list tksnip_motion $seq {%x} {%y}]
bind $can <ButtonRelease-1> [list tksnip_release1 $seq {%x} {%y}]
bind $can <Double-Button-1> [list tksnip_done $seq]
bind $can <Escape> [list tksnip_done $seq]
switch -exact $::tcl_platform(platform) {
windows { bind $win <Button-3> [list tksnip_done $seq]
bind $can <Button-3> [list tksnip_done $seq]
}
default { bind $win <Button-2> [list tksnip_done $seq]
bind $win <Command-Button-1> [list tksnip_done $seq]
bind $can <Button-2> [list tksnip_done $seq]
bind $can <Command-Button-1> [list tksnip_done $seq]
}
}
### auto-close if not completed within 30 seconds
set tksnip($seq,afterID) [after [expr {30 * 1000}] [list tksnip_expire $seq]]
### indicate that screenshot is ready
tksnip_flash $seq
### bring to focus
raise $win
focus $win
### wait for user to be done or until the time-out
vwait tksnip($seq,finito)
set retImg $tksnip($seq,final_img)
### delete the object
tksnip_delete $seq
return $retImg
}
################################
proc tksnip_delete {seq} {
global tksnip
catch {after cancel $tksnip($seq,afterID)}
catch {destroy $tksnip($seq,topwin)}
array unset tksnip "*,*"
}
################################
proc tksnip_done {seq} {
global tksnip
### all done
set tksnip($seq,finito) "finito..."
}
################################
proc tksnip_flash {seq} {
global tksnip
### toplevel window
set topwin $tksnip($seq,topwin)
### update toplevel border style as a visual clue
set orig [$topwin cget -relief]
set bd [$topwin cget -bd]
set styles [list sunken ridge]
set mod [llength $styles]
set newBD 8
### highlight the window
for {set i 0} {$i < 8} {incr i} {
after 200
$topwin config -bd $newBD \
-relief [lindex $styles [expr {$i % $mod}]]
update idletasks
}
### restore orig relief
$topwin config -bd $bd -relief $orig
}
################################
proc tksnip_button1 {seq x y} {
global tksnip
### start rubberbanding the screenshot area
set tksnip($seq,coords) [list $x $y $x $y]
### draw it
set tksnip($seq,region) [$tksnip($seq,canvas) \
create rectangle $x $y $x $y \
-dash {_} \
-outline #337f4c \
-fill #ffffbd \
-width 3
]
### make selected area visible
$tksnip($seq,canvas) raise $tksnip($seq,region) all
return
}
################################
proc tksnip_motion {seq x y} {
global tksnip
### update with new coordinates
lassign $tksnip($seq,coords) fromX fromY oldX oldY
set tksnip($seq,coords) [list $fromX $fromY $x $y]
### update the display
$tksnip($seq,canvas) coords $tksnip($seq,region) $fromX $fromY $x $y
}
################################
proc tksnip_release1 {seq x y} {
global tksnip
### get the start coordinates of the rubberband
lassign $tksnip($seq,coords) x1 y1 x2 y2
### width/height of the selected area
set regionw [expr {int(abs($x1 - $x2))}]
set regionh [expr {int(abs($y1 - $y2))}]
if {$x1 > $x2} {
set x1 $x2
set x1 $y2
}
set src_img $tksnip($seq,full_img)
set dest_img $tksnip($seq,dest_img)
set x2 [expr {min($x1 + $regionw, [image width $src_img])}]
set y2 [expr {min($y1 + $regionh, [image height $src_img])}]
### create a new image of the requested size
if {$dest_img eq ""} {
set temp_img [image create photo -width $regionw -height $regionh]
} else {
set temp_img [image create photo $dest_img \
-width $regionw -height $regionh]
}
### crop it
$temp_img copy $src_img -from $x1 $y1 $x2 $y2
set tksnip($seq,final_img) $temp_img
### done
tksnip_done $seq
}
################################
proc tksnip_expire {seq} {
global tksnip
### done
if {[info exists tksnip($seq,topwin)]} {
tksnip_done $seq
}
}
################################
proc tksnip_loupe {x y w h} {
if {[llength [info commands "loupe"]] == 0} {
### loupe command not available
return [list]
} else {
set img [image create photo -width $w -height $h]
loupe $img $x $y $w $h 1
return [list $img $x $y $w $h]
}
}
======