For other editors of bitmaps, including those useful as .ico Windows icons, see this [L1 ] April 2004 thread, which covers an interesting mix of shareware, Tk-based freeware, ...
Keith Vetter 2002-01-16 : here's a simple utility that lets you create and edit tk bitmap files.
I've written simplified versions of this code at least twice before, so when I found this particular version on my hard drive I thought I'd polish up and put it on wiki so that I, and others, can find it again in the future.
It's not as fancy as Paul Obermeier's poBitmap tool but then again, it's less than 1/25 the size.
KPV 2003-03-06 : added some editing functions like shift, invert, clear and best of all, resize.
#!/bin/sh # The next line is executed by /bin/sh, but not tcl \ exec wish $0 ${1+"$@"} ##+########################################################################## # # bitmap.tcl -- simple bitmap editor # by Keith Vetter # # Revisions: # KPV Jan 15, 2003 - initial revision # KPV Mar 06, 2003 - added functions like shift, clear, invert and resize # ##+########################################################################## ############################################################################# package require Tk set S(cell) 10 set S(prog) "Bitmap Editor" set S(fname) "" array set bits { 0 0000 1 1000 2 0100 3 1100 4 0010 5 1010 6 0110 7 1110 8 0001 9 1001 a 0101 b 1101 c 0011 d 1011 e 0111 f 1111} set bitmap { #define bullet_width 11 #define bullet_height 9 static char bullet_bits[] = { 0x00,0x00, 0x00,0x00, 0x70,0x00, 0xf8,0x00, 0xf8,0x00, 0xf8,0x00, 0x70,0x00, 0x00,0x00, 0x00,0x00 } } ##+########################################################################## # # DoDisplay -- sets up our display # proc DoDisplay {} { wm title . $::S(prog) canvas .c -width 500 -height 500 -bd 2 -relief ridge -highlightthickness 0 .c xview moveto 0 ; .c yview moveto 0 bind .c <2> [bind Text <2>] ;# Enable button 2 paning bind .c <B2-Motion> [bind Text <B2-Motion>] frame .fctrl -bd 2 -relief ridge label .info -text "Left button to set Right button to clear" -anchor c \ -bd 2 -relief ridge grid .c .fctrl -sticky news -row 0 grid .info ^ -sticky ew grid rowconfigure . 0 -weight 1 grid columnconfigure . 0 -weight 1 DoControl DoMenus update } ##+########################################################################## # # DoMenus -- sets up our menus # proc DoMenus {} { . configure -menu [menu .m -tearoff 0] .m add cascade -menu [menu .m.file -tearoff 0] -label "File" -underline 0 .m add cascade -menu [menu .m.image -tearoff 0] -label "Image" -underline 0 .m add cascade -menu [menu .m.help -tearoff 0] -label "Help" -underline 0 .m.file add command -label "New" -under 0 -command NewBMP .m.file add command -label "Open" -under 0 -command OpenBMP .m.file add command -label "Save" -under 0 -command SaveBMP .m.file add separator .m.file add command -label "Copy" -under 0 -command CopyBMP .m.file add separator .m.file add command -label Exit -under 1 -command exit .m.image add command -label "Clear" -under 0 -command {BitFunc clear} .m.image add command -label "Invert" -under 0 -command {BitFunc invert} .m.image add command -label "Shift left" -under 6 -command {BitFunc sleft} .m.image add command -label "Shift right" -under 6 -command {BitFunc sright} .m.image add command -label "Shift up" -under 6 -command {BitFunc sup} .m.image add command -label "Shift down" -under 6 -command {BitFunc sdown} .m.image add separator .m.image add command -label "Resize" -under 0 -command ResizeBMP .m.help add command -label About -under 0 -command About } ##+########################################################################## # # DoControl -- draws the control panel # proc DoControl {} { grid rowconfigure .fctrl 0 -minsize 10 grid rowconfigure .fctrl 100 -weight 1 frame .fctop grid .fctop - - -in .fctrl -row 1 set row 0 foreach a {Name Width Height} { set a2 [string map {" " ""} [string tolower $a]] label .l$a2 -text "$a:" entry .e$a2 -textvariable BM($a2) -width 8 -state disabled grid .l$a2 .e$a2 -in .fctop -row [incr row] } image create bitmap ::img::current frame .fimg -bd 2 -relief sunken -padx 10 -pady 10 label .limg -image ::img::current -bg white grid rowconfigure .fctrl 40 -minsize 50 grid .fimg - - -in .fctrl -row 41 pack .limg -in .fimg -expand 1 } ##+########################################################################## # # ShowBMP -- computes grid size then draws in the current bitmap # proc ShowBMP {} { global S BM if {! [info exists BM(raw)]} return set w [winfo width .c] ; set h [winfo height .c] set cw [expr {int((($w - 20) / $BM(width)))}] set ch [expr {int((($h - 20) / $BM(height)))}] set S(cell) [expr {$cw < $ch ? $cw : $ch}] if {$S(cell) > 40} { set S(cell) 40} if {$S(cell) < 5} { set S(cell) 5} DrawGrid ShowBits unset BM(bits) ::img::current config -data $BM(raw) ;# Update current bitmap display } ##+########################################################################## # # ClearBMP -- clears everything for a new bitmap # proc ClearBMP {} { global BM .c delete all ::img::current config -data {} array unset BM foreach arr [array names BM] { set BM($arr) ""} update } ##+########################################################################## # # DrawGrid -- draws the grid of rectangles--each one with proper bindings # proc DrawGrid {} { global BM .c delete all foreach {l t} [CellXY 0 0] break foreach {b r} [CellXY $BM(height) $BM(width)] break .c create rect $l $t $b $r -tag outline -width 2 set bg [.c cget -bg] for {set r 0} {$r < $BM(height)} {incr r} { for {set c 0} {$c < $BM(width)} {incr c} { .c create rect [CellXY $r $c] -tag [list grid c($r,$c)] -fill $bg .c bind c($r,$c) <1> [list Click 1 cell $r $c] .c bind c($r,$c) <3> [list Click 2 cell $r $c] } } .c config -scrollregion [.c bbox all] } ##+########################################################################## # # Click -- handles left and right mouse click in a grid cell # proc Click {btn what row col} { global BM if {$btn == 1} { ;# Set the pixel if {$BM(b,$row,$col)} return ;# Already set set BM(b,$row,$col) 1 ShowBitCell $row $col } else { ;# Clear the pixel if {! $BM(b,$row,$col)} return ;# Already cleare set BM(b,$row,$col) 0 .c delete o($row,$col) } set BM(raw) [UnparseBMP] ::img::current config -data $BM(raw) } ##+########################################################################## # # ShowBits -- draws dots in all "on" cells in the current bitmap, # only valid after ParseBMP fills in the BM(bits) variable. # proc ShowBits {} { global BM bits set row 0 set col 0 foreach byte $BM(bits) { foreach {n1 n2} [split $byte ""] break ;# Get each nibble foreach bit [split "$bits($n2)$bits($n1)" ""] { ;# Note the endian set BM(b,$row,$col) $bit if {$bit} { ShowBitCell $row $col } if {[incr col] >= $BM(width)} { ;# Do we past the last column? incr row set col 0 break } } } } ##+########################################################################## # # ShowBitCell -- draws the "on" bit in a specified cell # proc ShowBitCell {row col} { .c create oval [CellXY $row $col] -fill black -tag [list bit o($row,$col)] .c bind o($row,$col) <1> [list Click 1 oval $row $col] .c bind o($row,$col) <3> [list Click 2 oval $row $col] } ##+########################################################################## # # CellXY -- returns the coordinates of a grid cell # proc CellXY {r c} { global S set x1 [expr {10 + $c * $S(cell)}] set y1 [expr {10 + $r * $S(cell)}] set x2 [expr {$x1 + $S(cell)}] set y2 [expr {$y1 + $S(cell)}] return [list $x1 $y1 $x2 $y2] } ##+########################################################################## # # ParseBMP -- reads the raw bitmap data into our BM data structure # NB. face.bmp in demo directory had defines for x_hot and y_hot # proc ParseBMP {raw} { global S BM ClearBMP set BM(raw) $raw while {1} { if {! [regexp {\#define\s+(.*)_width} $raw => BM(name)]} break if {! [regexp {\#define\s+.*_width\s*(\d*)} $raw => BM(width)]} break if {! [regexp {\#define\s+.*_height\s*(\d*)} $raw => BM(height)]} break regexp {\#define\s+.*_x_hot\s*(\d*)} $raw => BM(xhot) regexp {\#define\s+.*_y_hot\s*(\d*)} $raw => BM(yhot) if {! [regexp {(0x.*)\}} $raw => BM(bits)]} break if {! [regsub -all {0x|,} $BM(bits) { } BM(bits)]} break if {! [regsub -all {\s+} $BM(bits) { } BM(bits)]} break set BM(bits) [string tolower $BM(bits)] return ;# Everything ok, get out } ERROR "$S(fname) is not a proper bmp file" ClearBMP } ##+########################################################################## # # OpenBMP -- opens and reads a BMP file # proc OpenBMP {} { global S set types { {{BMP Files} {.bmp}} {{All Files} * }} set fname [tk_getOpenFile -defaultextension ".bmp" -initialfile $S(fname) \ -filetypes $types] if {$fname == ""} return if {[catch {set FIN [open $fname r]} emsg]} { ERROR "Cannot open $fname\n$emsg" return } set raw [read $FIN] close $FIN set S(fname) $fname ParseBMP $raw ShowBMP } ##+########################################################################## # # SaveBMP -- saves the current bitmap to a file # proc SaveBMP {} { global S BM if {! [info exists BM(raw)]} return set types {{{BMP Files} {.bmp}} {{All Files} *}} set fname [tk_getSaveFile -defaultextension ".bmp" -initialfile $S(fname) \ -filetypes $types] if {$fname == ""} return if {[catch {set FOUT [open $fname w]} emsg]} { ERROR "Cannot open $fname\n$emsg" return } puts $FOUT $BM(raw) close $FOUT set S(fname) $fname } ##+########################################################################## # # UnparseBMP -- converts our internal BM into a proper bitmap data string # proc UnparseBMP {} { global BM set name $BM(name) set bmp "\#define ${name}_width $BM(width)\n" append bmp "\#define ${name}_height $BM(height)\n" if {[info exists BM(xhot)]} { append bmp "\#define ${name}_x_hot $BM(xhot)\n" append bmp "\#define ${name}_y_hot $BM(yhot)\n" } append bmp "static char ${name}_bits[] = \{\n" set bytes {} for {set r 0} {$r < $BM(height)} {incr r} { for {set c 0} {$c < $BM(width)} {incr c 8} { set byte 0 for {set cc [expr {$c + 7}]} {$cc >= $c} {incr cc -1} { set byte [expr {2 * $byte}] if {[info exists BM(b,$r,$cc)] && $BM(b,$r,$cc)} { incr byte } } lappend bytes [format 0x%02x $byte] } } append bmp " " [join $bytes ", "] append bmp "\n\}" return $bmp } ##+########################################################################## # # CopyBMP -- copies current bitmap to the clipboard # proc CopyBMP {} { global BM S if {! [info exists BM(raw)]} return clipboard clear clipboard append $BM(raw) tk_messageBox -icon info -title "$S(prog) Info" \ -message "Bitmap copied to the clipboard" } ##+########################################################################## # # NewBMP -- creates a blank, new bitmap with sizes specified by the user # proc NewBMP {} { global BM set n [NewDlg] if {$n == {}} return foreach {name width height} $n break ClearBMP set BM(name) $name set BM(width) $width set BM(height) $height for {set r 0} {$r < $BM(height)} {incr r} { for {set c 0} {$c < $BM(width)} {incr c} { set BM(b,$r,$c) 0 } } ParseBMP [UnparseBMP] ShowBMP } proc ResizeBMP {} { global BMP set n [NewDlg 1] if {$n == {}} return foreach {. nwidth nheight} $n break WidenBMP $nwidth HeightenBMP $nheight ParseBMP [UnparseBMP] ShowBMP } proc WidenBMP {nwidth} { global BM if {$BM(width) == $nwidth} return if {$nwidth > $BM(width)} { foreach {low high delete} [list $BM(width) $nwidth 0] break } else { foreach {low high delete} [list $nwidth $BM(width) 1] break } for {set row 0} {$row < $BM(height)} {incr row} { for {set col $low} {$col < $high} {incr col} { set BM(b,$row,$col) 0 if {$delete} { unset BM(b,$row,$col) } } } set BM(width) $nwidth } proc HeightenBMP {nheight} { global BM if {$BM(height) == $nheight} return if {$nheight > $BM(height)} { foreach {low high delete} [list $BM(height) $nheight 0] break } else { foreach {low high delete} [list $nheight $BM(height) 1] break } for {set col 0} {$col < $BM(width)} {incr col} { for {set row $low} {$row < $high} {incr row} { set BM(b,$row,$col) 0 if {$delete} { unset BM(b,$row,$col) } } } set BM(height) $nheight } ##+########################################################################## # # NewDlg -- asks the user for bitmap parameters # proc NewDlg {{resize 0}} { global S NEW BM destroy .new toplevel .new -padx 10 -pady 5 wm title .new "New Bitmap" if {$resize} {wm title .new "Resize Bitmap"} wm geom .new "+[expr {[winfo x .] + 150}]+[expr {[winfo y .] + 100}]" set NEW(ok) 0 set NEW(width) $BM(width) set NEW(height) $BM(height) frame .new.top -bd 2 -relief raised -padx 10 -pady 10 grid columnconfigure .new.top 1 -weight 1 set widgets {name width height} if {$resize} { set NEW(name) "xx" set widgets {width height} } foreach a $widgets { set a1 [string totitle $a] label .new.l$a -text "$a1:" entry .new.e$a -textvariable NEW($a) grid .new.l$a .new.e$a -in .new.top -sticky ew } frame .new.buttons button .new.ok -text Ok -width 10 -command ValidForm button .new.cancel -text Cancel -width 10 -command {destroy .new} pack .new.buttons -side bottom -pady 10 pack .new.top -side top -fill x pack .new.cancel .new.ok -in .new.buttons -side right -padx 10 -expand 1 raise .new set w ".new.e[lindex $widgets 0]" focus $w $w icursor end $w selection range 0 end tkwait window .new if {$NEW(ok)} { return [list $NEW(name) $NEW(width) $NEW(height)] } return {} } ##+########################################################################## # # ValidForm -- validates the NewDlg and then destroys it if it is ok # proc ValidForm {} { global NEW foreach n {name width height} { set NEW($n) [string trim $NEW($n)] if {$NEW($n) == ""} return } if {![string is integer $NEW(width)]} return if {![string is integer $NEW(height)]} return set NEW(ok) 1 destroy .new } proc ERROR {msg} { tk_messageBox -icon error -title "$::S(prog) Error" -message $msg } proc About {} { set msg "$::S(prog)\n\nby Keith Vetter\nJanuary 2003" tk_messageBox -title "About $::S(prog)" -message $msg -icon info } proc BitFunc {what} { global BM if {$what == "clear"} { foreach arr [array names BM b,*] { set BM($arr) 0 } } elseif {$what == "invert"} { foreach arr [array names BM b,*] { set BM($arr) [expr {! $BM($arr)}] } } elseif {$what == "sleft"} { ;# Shift left for {set col 0} {$col < $BM(width)} {incr col} { set col2 [expr {$col + 1}] for {set row 0} {$row < $BM(height)} {incr row} { if {[info exists BM(b,$row,$col2)]} { set BM(b,$row,$col) $BM(b,$row,$col2) } else { set BM(b,$row,$col) 0 } } } } elseif {$what == "sright"} { ;# Shift right for {set col [expr {$BM(width) - 1}]} {$col >= 0} {incr col -1} { set col2 [expr {$col - 1}] for {set row 0} {$row < $BM(height)} {incr row} { if {[info exists BM(b,$row,$col2)]} { set BM(b,$row,$col) $BM(b,$row,$col2) } else { set BM(b,$row,$col) 0 } } } } elseif {$what == "sup"} { ;# Shift up for {set row 0} {$row < $BM(height)} {incr row} { set row2 [expr {$row + 1}] for {set col 0} {$col < $BM(width)} {incr col} { if {[info exists BM(b,$row2,$col)]} { set BM(b,$row,$col) $BM(b,$row2,$col) } else { set BM(b,$row,$col) 0 } } } } elseif {$what == "sdown"} { ;# Shift down for {set row [expr {$BM(height) - 1}]} {$row >= 0} {incr row -1} { set row2 [expr {$row - 1}] for {set col 0} {$col < $BM(width)} {incr col} { if {[info exists BM(b,$row2,$col)]} { set BM(b,$row,$col) $BM(b,$row2,$col) } else { set BM(b,$row,$col) 0 } } } } set BM(raw) [UnparseBMP] RedrawBits ::img::current config -data $BM(raw) } proc RedrawBits {} { global BM .c delete bit for {set row 0} {$row < $BM(height)} {incr row} { for {set col 0} {$col < $BM(width)} {incr col} { if {$BM(b,$row,$col)} {ShowBitCell $row $col} } } } ################################################################ ################################################################ ################################################################ DoDisplay ParseBMP $bitmap ShowBMP
gold added pix