[ulis], 2004-03-30. Writing a 24bits Windows icon file from an image. (tested only on Win2k)

[http://perso.wanadoo.fr/maurice.ulis/tcl/img2icon.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 a 24bits Windows icon file (.ico) from an image
  # ------------------
  # parm1: image name
  # parm2: optional file name (defaults to icon.ico)
  # ------------------
  proc img2icon {img {fn icon.ico}} \
  {
    # get image
    set data [$img data]
    set height [llength $data]
    set width [llength [lindex $data 0]]
    PUTS "$fn: ${width}x$height"
    set text ""
    # compute size
    set strans [expr {$width / 8}]
    set mod [expr {$strans % 4}]
    if {$mod != 0} { incr strans [expr {4 - $mod}] }
    set size [expr {40 + ($width * $height * 3) + ($strans * $height)}]
    # create icon directory
    putword text 0  ; # Reserved
    putword text 1  ; # Type
    putword text 1  ; # Count
    # create icon entry
    putbyte text $width   ; # Width
    putbyte text $height  ; # Height
    putbyte text 0        ; # ColorCount
    putbyte text 0        ; # Reserved
    putword text 0        ; # Planes
    putword text 0        ; # BitCount
    putdword text $size   ; # BytesInRes
    putdword text 22      ; # ImageOffset
    # create icon header
    putdword text 40      ; # Size
    putdword text $width  ; # Width
    putdword text [expr {$height * 2}]  ; # Height
    putword text 1        ; # Planes
    putword text 24       ; # BitCount
    putdword text 0       ; # Compression
    putdword text [expr {$size - 40}]   ; # SizeImage
    putdword text 0       ; # XPelsPerMeter
    putdword text 0       ; # YPelsPerMeter
    putdword text 0       ; # ClrUsed
    putdword text 0       ; # ClrImportant
    # create icon bitmap
    PUTS "icon bitmap"
    for {set y [expr {$height - 1}]} {$y >= 0} {incr y -1} \
    {
      set n 0
      set row [lindex $data $y]
      for {set x 0} {$x < $width} {incr x} \
      {
        foreach {r g b} [winfo rgb . [lindex $row $x]] break
        foreach c {b g r} \
        {
          set $c [expr {[set $c] / 256}]
          putbyte text [set $c]
        }
        incr n 3
        PUTS -nonewline " [format #%02.2x%02.2x%02.2x $r $g $b]"
      }
      set mod [expr {$n % 4}]
      while {$mod != 0} { putbyte text 0; incr mod -1 }
      PUTS ""
    }
    # create transparency map
    PUTS "create transparency map"
    for {set y [expr {$height - 1}]} {$y >= 0} {incr y -1} \
    {
      set n 0
      for {set x 0} {$x < $width} {incr x} \
      { 
        set t [$img transparency get $x $y] 
        PUTS -nonewline " $t"
        putbits text $t 
        incr n 1
      }
      if {$::cbits != ""} \
      { while {[string length $::cbits] < 8} { append ::cbits 0; incr n } }
      set mod [expr {$n % 32}]
      while {$mod != 0} { putbyte text 0; incr mod -8 }
      PUTS ""
    }
    # put text to file
    set fp [open $fn w]
    fconfigure $fp -translation binary
    PUTS -nonewline $fp $text
    close $fp
  }
  # ------------------
  # put bits in text
  # (bits are cached and are really put when a byte is full)
  # ------------------
  # parm1: var name of text in calling space
  # parm2: value
  # ------------------
  proc putbits {text value} \
  {
    #PUTS -nonewline "putbits $text $value"
    upvar 1 $text txt
    append ::cbits $value
    while {[string length $::cbits] >= 8} \
    {
      set bits [string range $::cbits 0 7]
      set ::cbits [string range $::cbits 8 end]
      append txt [binary format B8 $bits]
      #PUTS -nonewline " ->\"$bits\""
    }
    #PUTS ""
  }
  # ------------------
  # put byte in text (1 byte)
  # ------------------
  # parm1: var name of text in calling space
  # parm2: value
  # ------------------
  proc putbyte {text value} \
  {
    upvar 1 $text txt
    append txt [binary format c1 $value]
    #PUTS "putbyte $text $value ->\"[binary format c1 $value]\""
  }
  # ------------------
  # put word in text (2 bytes)
  # ------------------
  # parm1: var name of text in calling space
  # parm2: value
  # ------------------
  proc putword {text value} \
  {
    upvar 1 $text txt
    append txt [binary format s1 $value]
    #PUTS "putword $text $value ->\"[binary format s1 $value]\""
  }
  # ------------------
  # put double word in text (4 bytes)
  # ------------------
  # parm1: var name of text in calling space
  # parm2: value
  # ------------------
  proc putdword {text value} \
  {
    upvar 1 $text txt
    append txt [binary format i1 $value]
    #PUTS "putdword $text $value ->\"[binary format i1 $value]\""
  }

----

'''Demo'''

  # =========================
  # demo
  # =========================

  # download "http://perso.wanadoo.fr/maurice.ulis/tcl/dinosaure.png"
  
  package require Tk
  package require Img
  set fn dinosaure.png
  wm title . $fn
  image create photo img -file $fn
  canvas .c -bd 0 -highlightt 0
  .c create image 0 0 -anchor nw -image img
  foreach {- - width height} [.c bbox all] break
  .c config -width $width -height $height
  pack .c
  img2icon img  
  wm iconbitmap . icon.ico
  
----

'''See also'''

   * [Reading a Windows icon file]
   * [windows icons]

----
[Category Example]