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]]