[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: * Doodle * Draw lines, rectangles and ovals * Change outline and fill color of objects * Save the drawing as .jpg or .gif ---- # Name: ScratchPad.tcl # Author: Martin Eder, snofix@users.sourceforge.net # 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(snofix@users.sourceforge.net)"} .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 {update_pos %x %y} bind .f.c {update_pos %x %y} ### Help text bind .panel.pointer {.status.bar configure -text "Move figure."} bind .panel.freehand {.status.bar configure -text "Doodle."} bind .panel.line {.status.bar configure -text "Draw lines"} bind .panel.rectangle {.status.bar configure -text "Draw rectangeles."} bind .panel.circle {.status.bar configure -text "Draw ovals."} bind .panel.thickness {.status.bar configure -text "Pen thickness."} bind .panel.pcol {.status.bar configure -text "Pen color."} bind .panel.pbcol {.status.bar configure -text "Fill color."} bind .f.c {.status.bar configure -text "Right click to delete."} } proc clear {} { .f.c delete all } proc pointer {} { draw_mode pointer bind .f.c { set startx %x set starty %y set seltag [.f.c gettag current] puts $seltag} bind .f.c { .f.c move $seltag [expr %x - $startx] [expr %y - $starty] set startx %x set starty %y update_pos %x %y } bind .f.c {} } 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 {set tempfree [.f.c create line %x %y %x %y -fill $::pcolor -width $::thickness]} bind .f.c { .f.c coords $tempfree [concat [.f.c coords $tempfree] %x %y] update_pos %x %y } bind .f.c {} } proc draw_line {} { draw_mode line bind .f.c {set linestartx %x; set linestarty %y} bind .f.c { .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 {.f.c create line $linestartx $linestarty %x %y -fill $::pcolor -width $::thickness} } proc draw_rectangle {} { draw_mode rectangle bind .f.c {set rectstartx %x; set rectstarty %y} bind .f.c { .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 { .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 {set circstartx %x; set circstarty %y} bind .f.c { .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 { .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 0 ---- [Category Graphics]