MEd 2006-02-01: Just another simple drawing tool, I use a very similar script as Scratch-Pad plugin for MetPad. Basically following actions are supported:
# Name: ScratchPad.tcl
# Author: Martin Eder, [email protected]
# Description: A simple scratch pad which provides free-hand drawing and
# basic geometric figures (lines, rectangels, circles).
# The drawing can be saved as jpg or gif file.
package require Img
set thickness 1
set thicklist "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 22 24 26 28 30"
set pcolor "black"
set pbcolor "white"
set savename ""
proc set_color {} {
set newcolor [tk_chooseColor -initialcolor $::pcolor -title "Choose new pencil color"]
if {$newcolor != ""} {
set ::pcolor $newcolor
.panel.pcol configure -bg $newcolor
}
}
proc set_bcolor {} {
set newcolor [tk_chooseColor -initialcolor $::pbcolor -title "Choose new fill color"]
if {$newcolor != ""} {
set ::pbcolor $newcolor
.panel.pbcol configure -bg $newcolor
}
}
proc set_canbg {} {
set newcolor [tk_chooseColor -initialcolor [.f.c cget -bg] -title "Choose new fill color"]
if {$newcolor != ""} {
set ::pbcolor $newcolor
.f.c configure -bg $newcolor
}
}
proc gui {} {
. configure -padx 5 -pady 5
wm title . "Scratch Pad"
frame .f -relief ridge -borderwidth 4
canvas .f.c -highlightthickness 0 -bg white
frame .panel
frame .status
label .status.pos -relief groove -width 9
label .status.bar -relief groove -anchor w
label .panel.space1 -width 2
label .panel.pcollab -text "Pen:"
button .panel.pcol -width 3 -bg $::pcolor -relief ridge -command set_color
label .panel.space2 -width 2
label .panel.pbcollab -text "Fill:"
button .panel.pbcol -width 3 -bg $::pbcolor -relief ridge -command set_bcolor
spinbox .panel.thickness -values $::thicklist -command {set ::thickness [.panel.thickness get]} -state readonly -width 3
button .panel.pointer -relief raised -command pointer -image [image create photo -data {
R0lGODlhEAAQAIMAAPwCBAQCBPz+xPz+BMTCBPz+/MTCxISChDQyNAAAAAAA
AAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAREEMhJg6BYWhAG
v5k2EKMXToSgEqc1DEIhvGAWpOvJFSXZyoXOxxY0BDahQDGg4xgOxmbgiWDq
poeqlGrVcZuSbLfpjwAAIf5oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8gdmVy
c2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwgcmlnaHRzIHJl
c2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==}]
button .panel.freehand -relief raised -command draw_free -image [image create photo -data {
R0lGODlhEAAQAPcAAAAAAP//////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
/////////////////////yH5BAEAAAEALAAAAAAQABAAAAg5AAMIHEiwYEEA
CAEYPKhwIUOHBhtCJChxosCKFjEmxBgA4UWPHUEO3BjRIkWTI1FeRJlwIkmV
BQMCADs=}]
button .panel.line -relief raised -command draw_line -image [image create photo -data {
R0lGODlhEAAQAPcAAAAAAP//////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
/////////////////////yH5BAEAAAEALAAAAAAQABAAAAgxAAMIHEiwoMGD
BwEAQGhQIcOGCx8SdChxIMWKFzFGrBggo0SPDEGG3KiRY0eSJgMEBAA7}]
button .panel.rectangle -relief raised -command draw_rectangle -image [image create photo -data {
R0lGODlhEAAQAPcAAAAAAP//////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
/////////////////////yH5BAEAAAEALAAAAAAQABAAAAg8AAMIHEiwoMGD
BgEoXMhQIcGGEAE8lHjQ4UCLCSkKxFiQI8eJICtqDPDx4siSG09GZDhxJUqE
MGPKLBgQADs=}]
button .panel.circle -relief raised -command draw_circle -image [image create photo -data {
R0lGODlhEAAQAPcAAAAAAP//////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
/////////////////////yH5BAEAAAEALAAAAAAQABAAAAhBAAMIHEiwYEEA
CBMiNBhAoUMABxdGhCgwIcOGFDFerEhR4kWJHhmCzCiyI0mDIzdqxHhyYEiL
Eyc+bMnSoUqVAQEAOw==}]
### Building the menu
. configure -menu [menu .padmenu]
.padmenu add cascade -label "File" -menu [menu .padmenu.file -tearoff 0]
.padmenu.file add command -label "Clear" -command clear
.padmenu.file add command -label "Background Color" -command {set_canbg}
.padmenu.file add separator
.padmenu.file add command -label "Save" -command {save_can $savename}
.padmenu.file add command -label "Save As" -command {save_can ""}
.padmenu.file add separator
.padmenu.file add command -label "About" -command {tk_messageBox -title "About" -message "Scratch Pad\n2006 by Martin Eder\n([email protected])"}
.padmenu.file add command -label "Exit" -command {destroy .}
pack .f.c -expand 1 -fill both
pack .f -expand 1 -fill both
pack .panel.pointer .panel.freehand .panel.line .panel.rectangle .panel.circle -side left -padx 1
pack .panel.thickness -side left -padx 10
pack .panel.pcollab .panel.pcol .panel.space1 .panel.pbcollab .panel.pbcol -side left
pack .status.bar -side left -fill x -expand 1
pack .status.pos -side right
pack .panel -fill x -pady 5
pack .status -fill x
bind .f.c <3> {.f.c delete current}
bind .f.c <Motion> {update_pos %x %y}
bind .f.c <B1-Motion> {update_pos %x %y}
### Help text
bind .panel.pointer <Enter> {.status.bar configure -text "Move figure."}
bind .panel.freehand <Enter> {.status.bar configure -text "Doodle."}
bind .panel.line <Enter> {.status.bar configure -text "Draw lines"}
bind .panel.rectangle <Enter> {.status.bar configure -text "Draw rectangeles."}
bind .panel.circle <Enter> {.status.bar configure -text "Draw ovals."}
bind .panel.thickness <Enter> {.status.bar configure -text "Pen thickness."}
bind .panel.pcol <Enter> {.status.bar configure -text "Pen color."}
bind .panel.pbcol <Enter> {.status.bar configure -text "Fill color."}
bind .f.c <Enter> {.status.bar configure -text "Right click to delete."}
}
proc clear {} {
.f.c delete all
}
proc pointer {} {
draw_mode pointer
bind .f.c <ButtonPress-1> {
set startx %x
set starty %y
set seltag [.f.c gettag current]
puts $seltag}
bind .f.c <B1-Motion> {
.f.c move $seltag [expr %x - $startx] [expr %y - $starty]
set startx %x
set starty %y
update_pos %x %y
}
bind .f.c <ButtonRelease-1> {}
}
proc draw_mode {widget} {
.panel.freehand configure -relief raised
.panel.line configure -relief raised
.panel.rectangle configure -relief raised
.panel.circle configure -relief raised
.panel.pointer configure -relief raised
.panel.$widget configure -relief sunken
}
proc draw_free {} {
draw_mode freehand
bind .f.c <ButtonPress-1> {set tempfree [.f.c create line %x %y %x %y -fill $::pcolor -width $::thickness]}
bind .f.c <B1-Motion> {
.f.c coords $tempfree [concat [.f.c coords $tempfree] %x %y]
update_pos %x %y
}
bind .f.c <ButtonRelease-1> {}
}
proc draw_line {} {
draw_mode line
bind .f.c <ButtonPress-1> {set linestartx %x; set linestarty %y}
bind .f.c <B1-Motion> {
.f.c delete templine
.f.c create line $linestartx $linestarty %x %y -width $::thickness -fill $::pcolor -tag templine
update_pos %x %y
}
bind .f.c <ButtonRelease-1> {.f.c create line $linestartx $linestarty %x %y -fill $::pcolor -width $::thickness}
}
proc draw_rectangle {} {
draw_mode rectangle
bind .f.c <ButtonPress-1> {set rectstartx %x; set rectstarty %y}
bind .f.c <B1-Motion> {
.f.c delete temprect
.f.c create rectangle $rectstartx $rectstarty %x %y -width $::thickness -fill $::pbcolor -outline $::pcolor -tag temprect
update_pos %x %y
}
bind .f.c <ButtonRelease-1> {
.f.c delete temprect
.f.c create rectangle $rectstartx $rectstarty %x %y -fill $::pbcolor -outline $::pcolor -width $::thickness
}
}
proc draw_circle {} {
draw_mode circle
bind .f.c <ButtonPress-1> {set circstartx %x; set circstarty %y}
bind .f.c <B1-Motion> {
.f.c delete tempcirc
.f.c create oval $circstartx $circstarty %x %y -width $::thickness -fill $::pbcolor -outline $::pcolor -tag tempcirc
update_pos %x %y
}
bind .f.c <ButtonRelease-1> {
.f.c delete tempcirc
.f.c create oval $circstartx $circstarty %x %y -fill $::pbcolor -outline $::pcolor -width $::thickness
}
}
proc save_can {filename} {
set canimg [image create photo -format window -data .f.c]
if {$filename == ""} {
set filename [tk_getSaveFile -title "Save Scratch Pad" -filetypes "\"{GIF Image} {.gif}\" \"{JPEG Image} {.jpg}\"" -initialdir [pwd] -initialfile "ScratchPad.gif"]
}
if {$filename != ""} {
set fext [file extension $filename]
switch -- $fext {
".gif" {set fformat "GIF"}
".jpg" {set fformat "JPEG"}
default {tk_messageBox -title "Unsupported format" -message "Unsupported format.\nPlease use gif or jpg extension.\n" -icon error; return}
}
$canimg write $filename -format $fformat
}
set savename $filename
}
proc update_pos {xp yp} {
set offset 0
set xpos [expr $xp - $offset]
set ypos [expr $yp - $offset]
.status.pos configure -text "$xpos, $ypos"
}
gui
draw_free
update_pos 0 0MG You could consolidate those three procs at the start for changing colours into one if you passed the info that changes (the varname to be set / proc whose colour should be altered / title) as args, to save repeating almost-identical code. Something like this (proc name changed/'if 0' added so it doesn't clash with the real code above) would probably work
if 0 {
proc set_color2 {var widget {keyword "fill"}} {
set newcolor [tk_chooseColor -initialcolor [set $var] -title "Choose new $keyword color"]
if { $newcolor != "" } {
set $var $newcolor
$widget configure -bg $newcolor
}
}
button .panel.pcol -width 3 -bg $::pcolor -relief ridge -command [list set_color2 ::pcolor .panel.pcol pencil]
}