1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
# *- tcl -*-
# ### ### ### ######### ######### #########
# Copyright (c) 2004 George Petasis
# Origin http://wiki.tcl.tk/1404 [24-10-2004]
# BSD licensed.
# ### ### ### ######### ######### #########
## Requisites
package require Tcl 8.5
package require Tk 8.5
package require img::window
namespace eval ::canvas {}
# ### ### ### ######### ######### #########
## Implementation.
proc ::canvas::snap {canvas} {
# Ensure that the window is on top of everything else, so as not
# to get white ranges in the image, due to overlapped portions of
# the window with other windows...
raise [winfo toplevel $canvas]
update
# XXX: Undo the raise at the end ?!
set border [expr {[$canvas cget -borderwidth] +
[$canvas cget -highlightthickness]}]
set view_height [expr {[winfo height $canvas]-2*$border}]
set view_width [expr {[winfo width $canvas]-2*$border}]
lassign [$canvas bbox all] x1 y1 x2 y2
#foreach {x1 y1 x2 y2} [$canvas bbox all] break
set x1 [expr {int($x1-10)}]
set y1 [expr {int($y1-10)}]
set x2 [expr {int($x2+10)}]
set y2 [expr {int($y2+10)}]
set width [expr {$x2-$x1}]
set height [expr {$y2-$y1}]
set image [image create photo -height $height -width $width]
# Arrange the scrollregion of the canvas to get the whole window
# visible, so as to grab it into an image...
# Save the scrolling state, as this will be overidden in short order.
set scrollregion [$canvas cget -scrollregion]
set xscrollcommand [$canvas cget -xscrollcommand]
set yscrollcommand [$canvas cget -yscrollcommand]
$canvas configure -xscrollcommand {}
$canvas configure -yscrollcommand {}
set grabbed_x $x1
set grabbed_y $y1
set image_x 0
set image_y 0
while {$grabbed_y < $y2} {
while {$grabbed_x < $x2} {
set newregion [list \
$grabbed_x \
$grabbed_y \
[expr {$grabbed_x + $view_width}] \
[expr {$grabbed_y + $view_height}]]
$canvas configure -scrollregion $newregion
update
# Take a screenshot of the visible canvas part...
set tmp [image create photo -format window -data $canvas]
# Copy the screenshot to the target image...
$image copy $tmp -to $image_x $image_y -from $border $border
# And delete the temporary image (leak in original code)
image delete $tmp
incr grabbed_x $view_width
incr image_x $view_width
}
set grabbed_x $x1
set image_x 0
incr grabbed_y $view_height
incr image_y $view_height
}
# Restore the previous scrolling state of the canvas.
$canvas configure -scrollregion $scrollregion
$canvas configure -xscrollcommand $xscrollcommand
$canvas configure -yscrollcommand $yscrollcommand
# At last, return the fully assembled snapshot
return $image
}
# ### ### ### ######### ######### #########
## Ready
package provide canvas::snap 1.0.1
return
|
