Version 1 of Transparent Toplevel

Updated 2003-12-06 00:32:25

Someone was enquiring on the Tcl'ers Chat if Tk could do transparent toplevels. It can't natively, but you can simulate them using a canvas. Here is some code which should work on Microsoft Windows systems. It simply gets the wallpaper picture by querying the registry, and then draws the appropriate part of it as a background on the canvas. There are some problems, which should be addressed:

  • Only works on windows (unix/mac code would be welcome)
  • Assumes scaled wallpaper (you can check the WallpaperTile value to see if it's actually tiled, and possibly other registry settings - I'll leave that as an exercise...)
  • Only scales the image by integer amounts - this is a limitation of Tk's image scaling code.
  • You have to pack child widgets into $path.c - the canvas. You could use snit or some other code to make this more transparent (no pun intended).
 # Creates a "transparent" window on windows...
 package require Tk
 package require registry
 package require Img

 proc transtop {path args} {
     uplevel 1 [list toplevel $path] $args
     # Create a canvas in this toplevel
     pack [canvas $path.c] -fill both -expand 1
     # Find out the desktop wallpaper image
     set file [registry get HKEY_CURRENT_USER\\Control\ Panel\\Desktop \
         Wallpaper]
     set im [image create photo -file [file normalize $file]]
     set bg [image create photo]
     set scalex [expr {int(double([winfo screenwidth $path]) / 
                 double([image width $im]) + 0.9)}]
     set scaley [expr {int(double([winfo screenheight $path]) / 
                 double([image height $im]) + 0.9)}]
     $bg copy $im -zoom $scalex $scaley
     set id [$path.c create image 0 0 -anchor nw -image $bg]
     updateBgImage $path.c $id
     bind $path <Configure> [list updateBgImage $path.c $id] 

     return $path
 }

 proc updateBgImage {c id} {
     set x [expr {0 - [winfo rootx $c]}]
     set y [expr {0 - [winfo rooty $c]}]
     $c coords $id $x $y
 }

 if {$argv0 eq [info script]} {
     # Main
     transtop .t
     bind .t <Destroy> { exit }
     wm withdraw .
 }