bitmap.to.photo

I found that I needed to copy bitmap image data into a photo image. Since photo doesn't like bitmap data, I wrote up a little XBM reader that does the job. This may be completely pointless, but here it is anyway.

The first proc simply creates a photo image with the same arguments as the "image create bitmap" command takes (except you cannot name the resulting image).

  proc image.create.xbm args {
    array set a $args
  
    if {[array names a -exact -file] ne {}} {
      set fid [open $a(-file) r]
      set a(-data) [read $fid]
      close $fid
      }
    if {[array names a -exact -maskfile] ne {}} {
      set fid [open $a(-maskfile) r]
      set a(-maskdata) [read $fid]
      close $fid
      }
  
    if {[array names a -exact -foreground] eq {}} {set a(-foreground) black}
    if {[array names a -exact -background] eq {}} {set a(-background) {}}
  
    if {$a(-background) eq {}} {
      set a(-maskdata)   $a(-data)
      set a(-background) white
      }
  
    set width  [lindex [regexp -inline -- {width\s+(\d+)}  $a(-data)] 1]
    set height [lindex [regexp -inline -- {height\s+(\d+)} $a(-data)] 1]
    set result [image create photo -width $width -height $height]
    regexp -indices -- {\{\s*(0x[^\}]*)} $a(-data) r1 range
    foreach {b e} $range break
    set data   [join [split [string trim [string range $a(-data) $b $e]] ,]]
  
    set line   {}
    set ycntr0 0
    set ycntr1 1
    foreach datum $data {
      foreach cntr {0 1 2 3 4 5 6 7} {
        if {($datum %2) == 0} \
          then {lappend line $a(-background)} \
          else {lappend line $a(-foreground)}
        set datum [expr {$datum >> 1}]
        }
      if {[llength $line] >= $width} {
        $result put [list $line] -to 0 $ycntr0 $width $ycntr1
        incr ycntr0
        incr ycntr1
        set line {}
        }
      }
  
    if {[array names a -exact -maskdata] ne {}} {
      set w      [lindex [regexp -inline -- {width\s+(\d+)}  $a(-data)] 1]
      set h      [lindex [regexp -inline -- {height\s+(\d+)} $a(-data)] 1]
      if {($w != $width) || ($h != $height)} {
        error {bitmap and mask have different sizes}
        }
      regexp -indices -- {\{\s*(0x[^\}]*)} $a(-maskdata) r1 range
      foreach {b e} $range break
      set data [join [split [string trim [string range $a(-maskdata) $b $e]] ,]]
  
      set ycntr 0
      set xcntr 0
      foreach datum $data {
        foreach cntr {0 1 2 3 4 5 6 7} {
          if {($datum %2) == 0} {
            $result transparency set $xcntr $ycntr true
            }
          set datum [expr {$datum >> 1}]
          incr xcntr
          if {$xcntr >= $width} {
            incr ycntr
            set  xcntr 0
            break
            }
          }
        }
      }
  
    return $result
    }

This next proc takes a bitmap image and returns a photo image.

  proc image.bitmap.to.photo bmp {
    set options {}
    foreach opt {-background -data -file -foreground -maskdata -maskfile} {
      lappend options $opt [$bmp cget $opt]
      }
    return [eval image.create.xbm $options]
    }

If you're using Tcl/Tk 8.5+ you can change that last line to

  return [image.create.xbm {*}$options]

Duoas 2007-05-07 22:03

2009-10-26 17:14 I don't ever remember not making a comment here... but anyway...

The above proc fails if your bitmap does not have a mask. A simple update:

  proc image.bitmap.to.photo bmp {
    set options {}
    foreach opt {-background -data -file -foreground -maskdata -maskfile} {
      set val [$bmp cget $opt]
      if {$val ne {}} {
        lappend options $opt $val
        }
      }
    return [eval image.create.xbm $options]
    }

Not as pretty, I know... but it works.

Category Image Processing