How it does?This proc reads a binary file using fconfigure -translation binary & binary scan to translate from binary to Tcl strings.
Procs(set ::DEBUG to 1 to have a trace)
# ------------------
# debug
# ------------------
set ::DEBUG 1
if {[info exists ::DEBUG] && $::DEBUG} \
{ interp alias {} PUTS {} puts } \
else \
{
proc NULL {args} {}
interp alias {} PUTS {} NULL
}
# ------------------
# create n images from a Windows icon file (.ico)
# ------------------
# parm1: file name
# parm2: images name prefix
# ------------------
# return: count of created images
# image names are: <prefix>0,... <prefix><count - 1>
# ------------------
proc ico2img {fn {ip img}} \
{
# read file
set fp [open $fn]
fconfigure $fp -translation binary
set text [read $fp]
close $fp
# header
set ph 0
PUTS "$fn:"
foreach var {filler resType iconsCount} \
{
set $var [getword $text $ph]
if {$var != "filler"} \
{ PUTS "\t[format %-15.15s $var] [set $var]" }
incr ph 2
}
# icons
for {set i 0} {$i < $iconsCount} {incr i} \
{
# icon dir entry
PUTS "icon dir entry #$i"
foreach var {iconWidth iconHeight iconColors filler} \
{
set $var [getbyte $text $ph]
if {$var != "filler"} \
{ PUTS "\t[format %-15.15s $var] [set $var]" }
incr ph 1
}
foreach var {filler iconBits} \
{
set $var [getword $text $ph]
if {$var != "filler"} \
{ PUTS "\t[format %-15.15s $var] [set $var]" }
incr ph 2
}
foreach var {resSize iconOffset} \
{
set $var [getdword $text $ph]
PUTS "\t[format %-15.15s $var] [set $var]"
incr ph 4
}
# icon header
set pi $iconOffset
PUTS "icon header #$i"
foreach var {filler iconWidth iconHeight} \
{
set $var [getdword $text $pi]
if {$var != "filler"} \
{ PUTS "\t[format %-15.15s $var] [set $var]" }
incr pi 4
}
set iconHeight [expr {$iconHeight / 2}]
foreach var {filler iconBits} \
{
set $var [getword $text $pi]
if {$var != "filler"} \
{ PUTS "\t[format %-15.15s $var] [set $var]" }
incr pi 2
}
foreach var {filler iconSize filler filler filler filler} \
{
set $var [getdword $text $pi]
if {$var != "filler"} \
{ PUTS "\t[format %-15.15s $var] [set $var]" }
incr pi 4
}
# create image
set img ${ip}$i
PUTS "image create photo $img -width $iconWidth -height $iconHeight"
image create photo $img -width $iconWidth -height $iconHeight
if {$iconBits < 24} \
{
# color map
PUTS -nonewline "color map #$i"
set count [expr {int(pow(2,$iconBits))}]
for {set nb 0} {$nb < $count} {incr nb} \
{
foreach c {b g r} \
{
set $c [string range [format %02x [getbyte $text $pi]] end-1 end]
incr pi
}
incr pi
set color($nb) #$r$g$b
if {$nb % 16 == 0} { PUTS -nonewline "\n\t[format %3.3s $nb]" }
PUTS -nonewline " $color($nb)"
}
# image
PUTS "\nimage #$i"
set pb 0
set data {}
for {set y 0} {$y < $iconHeight} {incr y} \
{
set row {}
set n 0
for {set x 0} {$x < $iconWidth} {incr x} \
{
set cid [getbits $text $pi $pb $iconBits]
PUTS -nonewline " [format %3.3s $cid]"
set c $color($cid)
lappend row $c
incr pb $iconBits
incr n $iconBits
}
set mod [expr {$n % 32}]
if {$mod != 0} { incr pb [expr {32 - $mod}] }
PUTS ""
set data [linsert $data 0 $row]
}
incr pi [expr {$pb / 8}]
} \
else \
{
# true color image
set data {}
for {set y 0} {$y < $iconHeight} {incr y} \
{
set row {}
set n 0
for {set x 0} {$x < $iconWidth} {incr x} \
{
foreach c {b g r} \
{
set $c [getbyte $text $pi]
set $c [format %02.2x [set $c]]
set $c [string range [set $c] end-1 end]
incr pi
incr n
}
set c #$r$g$b
PUTS -nonewline " $c"
lappend row $c
}
set mod [expr {$n % 4}]
if {$mod != 0} { incr pi [expr {4 - $mod}] }
PUTS ""
set data [linsert $data 0 $row]
}
}
$img put $data
# transparency
PUTS "\ntransparency #$i ([format %x $pi])"
set pb 0
for {set y 0} {$y < $iconHeight} {incr y} \
{
for {set x 0} {$x < $iconWidth} {incr x} \
{
set transparency [getbits $text $pi $pb 1]
if {$transparency} \
{
set Y [expr {$iconHeight - $y - 1}]
$img transparency set $x $Y 1
}
incr pb
PUTS -nonewline " $transparency"
}
set mod [expr {$pb % 32}]
if {$mod != 0} { incr pb [expr {32 - $mod}] }
PUTS ""
}
#package require Img
#img0 write messenger.png -format PNG
}
# images count
return $iconsCount
}
# ------------------
# get bits from text (n bits)
# ------------------
# parm1: text
# parm2: byte offset
# parm3: bits offset
# parm4: bits width
# ------------------
# return: decimal value of the extracted bits
# ------------------
proc getbits {text offset pbits width} \
{
set extra [expr {$pbits % 8}]
set offset [expr {$offset + $pbits / 8}]
set width2 [expr {$width + $extra}]
set offset2 [expr {$offset - 1 + ($width2 + 7) / 8}]
set bits [string range $text $offset $offset2]
binary scan $bits B$width2 bvalue
set bvalue2 [string range $bvalue $extra end]
set value 0
foreach bit [split $bvalue2 {}] \
{
incr value $value
incr value $bit
}
return $value
}
# ------------------
# get byte from text (1 byte)
# ------------------
# parm1: text
# parm2: byte offset
# ------------------
# return: decimal value of the extracted byte
# ------------------
proc getbyte {text offset} \
{
#PUTS "getbyte $offset"
set byte [string index $text $offset]
binary scan $byte c1 value
return $value
}
# ------------------
# get word from text (2 bytes)
# ------------------
# parm1: text
# parm2: word offset
# ------------------
# return: decimal value of the extracted word
# ------------------
proc getword {text offset} \
{
#PUTS "getword $offset"
set word [string range $text $offset [incr offset]]
binary scan $word s1 value
return $value
}
# ------------------
# get double word from text (4 bytes)
# ------------------
# parm1: text
# parm2: double word offset
# ------------------
# return: decimal value of the extracted double word
# ------------------
proc getdword {text offset} \
{
#PUTS "getdword $offset"
set dword [string range $text $offset [incr offset 3]]
binary scan $dword i1 value
return $value
}
----
'''Demo'''
# =========================
# demo
# =========================
# download "http://perso.wanadoo.fr/maurice.ulis/tcl/explorer.ico"
# download "http://perso.wanadoo.fr/maurice.ulis/tcl/lynx.ico"
package require Tk
set fn lynx.ico
#set fn explorer.ico
wm title . $fn
set count [ico2img $fn]
canvas .c -bd 0 -highlightt 0
set y 0
for {set i 0} {$i < $count} {incr i} \
{
.c create image 0 $y -anchor nw -image img$i
incr y [image height img$i]
}
foreach {- - width height} [.c bbox all] break
.c config -width $width -height $height
pack .cSee also
- Writing a Windows icon file
- already exists, please see windows icons
- Img (supports .ico files for the photo images)
How about reading an icon image from a Windows .exe file?see the tklib package ico
