Updated 2010-10-13 13:25:31 by Kroc

MG - March 26th 2004. A small proc which turns every pixel in a photo image which matches a color of your choice to transparency. It uses the Img package, and saves the image in the same format, by default (although, if you're editing a bitmap or something, an option to save as a GIF or PNG instead would probably be useful). Only tested on Windows (98 and XP), though I don't see any reason why it wouldn't work on other platforms. The 'GUI' - and I use the term loosely - could use some sprucing up, but I just whipped this up quickly and couldn't be bothered improving it, at the time; if someone wants to, feel free. This is rather slow for large images, but it's the only way I can find to do this in Tcl :)

MG March 1st 2007 - The above actually wasn't true - it always outputted as a GIF. Modified now to always output as a PNG, as that seems the most useful format, as it doesn't throw an error when used on a file with more than 256 colors. Thanks to Rich for pointing out the error.
 package require Img
 set types {
            {{All Images} {.gif}  {}}
            {{All Images} {.jpeg} {}}
            {{All Images} {.jpg}  {}}
            {{All Images} {.bmp}  {}}
            {{All Images} {.tiff} {}}
            {{All Images} {.png}  {}}
            {{All Files}  {.*}    {}}
            {{Gif Images} {.gif}  {}}
            {{Jpeg Images} {.jpg} {}}
            {{Jpeg Images} {.jpeg} {}}
            {{Bitmap Images} {.bmp} {}}
            {{Tiff Images} {.tiff} {}}
            {{PNG Images} {.png} {}}
         }


 set text "Type the name of the file into the field, or click 'Browse' and select it. "
 append text "Click the button to select which color to make transparent. "
 append text "ALL pixels in the image in this color will be made transparent. "
 append text "The new image will be called TRANS<OriginalName>.<format> "
 append text "(note: this may take some time to run for large images)"
 label .l -text $text -wrap 400p
 pack .l -side top -padx 2 -pady 4
 frame .f
 pack .f -side top -pady 4
 entry .f.e -width 40 -textvariable ::filename
 button .f.b -text "Browse..." -command "browseFile"
 pack .f.e .f.b -side left -padx 3
 frame .f2
 pack .f2 -side top -pady 4
 frame .f3
 pack .f3 -side top -pady 4
 set color2use "white"
 button .f3.b -text "Change Color..." -command {setColor}
 label .f3.l -text "Example:"
 button .f3.ex -background $color2use -width 5
 bindtags .f3.ex {}
 pack .f3.b .f3.l .f3.ex -side left -padx 4
 frame .f4
 pack .f4 -side top -pady 4
 button .f4.b -text "Go!" -command recolImage
 pack .f4.b
 
 proc recolImage {} {
   global filename color2use
   if { ![file exists $filename] || ![file isfile $filename] } {
        tk_messageBox -message "Invalid file \"$filename\""
        return;
      }
 
   if { [catch {image create photo original -file $filename}] } {
        tk_messageBox -message "Invalid image."
        return;
      }
 
   if { [catch {winfo rgb . $color2use} rgb] } {
        tk_messageBox -message "Invalid color \"$color2use\""
        return;
      }
 
   set rgb2 [list [expr [lindex $rgb 0]/256] [expr [lindex $rgb 1]/256] [expr [lindex $rgb 2]/256]]

   set h [image height original] ; set w [image width original]
   for { set x 0 } {$x < $w} {incr x} {
         for {set y 0} {$y < $h} {incr y} {
              puts "COORDS: $x $y"
              update
              if { [original get $x $y] == $rgb2 } {
                   original transparency set $x $y 1
                 }
             }
        }
 
   set newFile [file join [file dirname $filename] "TRANS[file rootname [file tail $filename]].png"]
   original write $newFile -format png
   if { [file exists $newFile] } {
        tk_messageBox -title Transparency -message "Transparency created successfully at \"[file normalize [file nativename $newFile]]\""
        exit;
      } else {
        tk_messageBox -title "Transparency" -message "Error creating image file at \"[file normalize [file nativename $newFile]]\""
        catch {image delete original}
      }
 
 };# recolImage
 
 proc setColor {} {
   global color2use
 
   set newcol [tk_chooseColor -title "Select Color" -initialcolor $color2use]
   if { $newcol != "" } {
        set color2use $newcol
      }
   .f3.ex configure -bg $color2use
 
 };# setColor
 
 proc browseFile {} {
 
   set newfile [tk_getOpenFile -filetypes $::types -initialdir ~/windows/desktop]
   if { $newfile != "" } {
        global filename
        set filename [file nativename [file normalize $newfile]]
      }
 };# browseFile
 catch {console show}

TS Google for "giftool" or "giftrans" if you need faster tools for GIFs.

RS 2006-01-11 did not know this page, but had a similar requirement - here's what I did:
 proc transparent {image color} {
    set r -1
    foreach row [$image data] {
       incr r
       set c -1
       foreach col $row {
          incr c
          if {$col eq $color} {$image transparency set $c $r 1}
       }
    }
 }

However, even though I did nothing time-consuming (like update or puts further above), the timing behavior is still frustrating: for a black/white image of 624*228, it took over 20 seconds to march through it :(

Kroc - Another quick and dirty way to do it in one line :
 image create photo transp -data [string map {"c #ffffff" "c None"} [$image data -format XPM]]