This was a Tcl/TK learning program to take a look at several things:
- Canvas
- Drag and Drop shapes onto a canvas
- Create an image (.png) of that canvas
#c1 - TCL/TK Learning about Canvas/photoimage
#wjk@wjk.NOSPAMmv.com
proc CanvasToPic { canvasID } {
set returnThis [catch {package require Img} version]
#Gets the contents of the canvas canvasID and put into photo image photoimage.
set returnThis [catch {image create photo -format window -data $canvasID} photoimage]
if { $returnThis != 0 } {
puts "\nERROR: Cannot create photo!!!"
exit 1
}
return $photoimage
}
canvas .c1 -width 460 -height 350 -bg white -relief groove \
-borderwidth 4
grid .c1 -row 1 -column 1 -columnspan 2
frame .f1
button .f1.b1 -text "Selection Board" -command {
.c1 create line 55 0 55 350 -width 2
for { set q 1 } { $q <= 21 } { incr q } {
.c1 create rect 10 10 30 30 -fill red -tag movable
.c1 create poly 30 10 30 30 50 30 -fill blue -tag movable -outline black
.c1 create poly 30 10 50 10 50 30 -fill blue -tag movable -outline black
.c1 create rect 10 30 30 50 -fill red -tag movable
.c1 create poly 30 30 30 50 50 30 -fill blue -tag movable -outline black
.c1 create poly 50 30 30 50 50 50 -fill blue -tag movable -outline black
.c1 create rect 10 50 30 70 -fill blue -tag movable
.c1 create poly 30 50 30 70 50 50 -fill red -tag movable -outline black
.c1 create poly 50 50 30 70 50 70 -fill red -tag movable -outline black
.c1 create rect 10 70 30 90 -fill blue -tag movable
.c1 create poly 30 70 30 90 50 90 -fill red -tag movable -outline black
.c1 create poly 30 70 50 70 50 90 -fill red -tag movable -outline black
.c1 create rect 10 90 30 110 -fill green -tag movable
.c1 create poly 30 90 30 110 50 110 -fill yellow -tag movable -outline black
.c1 create poly 30 90 50 90 50 110 -fill yellow -tag movable -outline black
.c1 create poly 30 50 30 70 50 50 -fill red -tag movable -outline black
.c1 create poly 50 50 30 70 50 70 -fill red -tag movable -outline black
.c1 create rect 10 110 30 130 -fill green -tag movable
.c1 create poly 30 110 30 130 50 130 -fill yellow -tag movable -outline black
.c1 create poly 30 110 50 110 50 130 -fill yellow -tag movable -outline black
.c1 create rect 10 130 30 150 -fill yellow -tag movable
.c1 create poly 30 130 30 150 50 130 -fill green -tag movable -outline black
.c1 create poly 50 130 30 150 50 150 -fill green -tag movable -outline black
.c1 create rect 10 150 30 170 -fill yellow -tag movable
.c1 create poly 30 150 30 170 50 150 -fill green -tag movable -outline black
.c1 create poly 50 150 30 170 50 170 -fill green -tag movable -outline black
.c1 create rect 10 170 30 190 -fill lightgreen -tag movable
.c1 create rect 30 170 50 190 -fill lightblue -tag movable
.c1 create rect 10 190 30 210 -fill black -tag movable
.c1 create rect 30 190 50 210 -fill white -tag movable -outline black
.c1 create rect 10 210 30 230 -fill brown -tag movable
.c1 create rect 30 210 50 230 -fill orange -tag movable -outline black
.c1 create rect 10 230 30 250 -fill black -tag movable
.c1 create rect 30 230 50 250 -fill white -tag movable -outline black
.c1 create rect 10 250 30 270 -fill brown -tag movable
.c1 create rect 30 250 50 270 -fill orange -tag movable -outline black
.c1 create rect 10 270 30 290 -fill cyan -tag movable
.c1 create rect 30 270 50 290 -fill grey -tag movable -outline black
.c1 create rect 10 290 30 310 -fill magenta -tag movable
.c1 create rect 30 290 50 310 -fill purple -tag movable -outline black
.c1 create oval 10 310 30 330 -fill brown -tag movable
.c1 create oval 30 310 50 330 -fill orange -tag movable -outline black
.c1 create oval 10 330 30 350 -fill red -tag movable
.c1 create oval 30 330 50 350 -fill blue -tag movable -outline black
}
.f1.b1 configure -state disabled
}
button .f1.b2 -text "Clear All" -command {
.c1 delete all
.f1.b1 configure -state normal
}
button .f1.b3 -text "MakePngImage" -command {
set photoimage [CanvasToPic .c1]
puts $photoimage
puts "Writing photoimage in PNG format: photoimage.png"
$photoimage write photoimage.png -format PNG
}
pack .f1.b1 -side left
pack .f1.b2 -side left
pack .f1.b3 -side left
grid .f1 -row 2 -column 1
proc CanvasMarkIt { x y can } {
global canvas
$can raise current
set x [$can canvasx $x]
set y [$can canvasy $y]
set canvas($can,obj) [ $can find closest $x $y ]
set canvas($can,x) $x
set canvas($can,y) $y
}
proc CanvasDragIt { x y can } {
global canvas
set x [$can canvasx $x]
set y [$can canvasy $y]
set dx [expr $x - $canvas($can,x)]
set dy [expr $y - $canvas($can,y)]
$can move $canvas($can,obj) $dx $dy
set canvas($can,x) $x
set canvas($can,y) $y
}
.c1 bind movable <Button-1> {CanvasMarkIt %x %y %W}
.c1 bind movable <B1-Motion> {CanvasDragIt %x %y %W}
Screenshots
gold added pix
