Writing a Windows icon file

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

LES says that it works on Windows 98. But it's so slow... ulis, 2004-03-30: See MG's remark near the end of the page.

How it does?

This proc writes a binary file using fconfigure -translation binary & binary format to translate from Tcl strings to binary.

Procs edit

(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 edit

  # =========================
  # 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

MG March 30th - Can you not use this, too?

 package require Tk
 package require Img
 image create photo img -file $fn
 img write $fn.ico -format ico

ulis, 2004-03-30: Lol! That works perfectly! I verified that Img supports .ico files for the photo images.

Procs edit

Demo edit

See also edit