[ulis], 2004-03-29. 

2004-03-29. Killed some bugs. Tested only on Win2k: let me know if you used it on WinXP (and 32bits icons).

[http://perso.wanadoo.fr/maurice.ulis/tcl/explorer.ico.png]
[http://perso.wanadoo.fr/maurice.ulis/tcl/lynx.ico.png]

----

'''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 .c

----

'''See also'''

   * [Writing a Windows icon file]
   * already exists, please see [windows icons]

----

[Category Example]