home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / demos / Img / tkv.tcl < prev   
Encoding:
Text File  |  2001-10-22  |  4.8 KB  |  177 lines
  1. #!/bin/sh
  2. # The next line restarts using wish8.3 \
  3. exec wish8.3 $0 ${1+"$@"}
  4.  
  5. source [file join [file dirname [info script]] imgmsg.tcl]
  6.  
  7. proc mmc string {
  8.     regsub & $string {} string
  9.     return $string
  10. }
  11.  
  12. proc mml string {
  13.     return [string first & $string]
  14. }
  15.  
  16. #
  17. # Make the Image format available.
  18. #
  19.  
  20. package require Img
  21.  
  22. #
  23. # Initialization of some global variables
  24. #
  25.  
  26. set tkvPriv(count) 0
  27. set tkvPriv(currentdir) [pwd]
  28. set tkvPriv(defaultext) .gif
  29.  
  30. set tkvPriv(types) [list \
  31.     [list [mc "Image Files"]    {.bmp}        ] \
  32.     [list [mc "Image Files"]    {.gif}        ] \
  33.     [list [mc "Image Files"]    {.jpeg .jpg}    ] \
  34.     [list [mc "Image Files"]    {.png}        ] \
  35.     [list [mc "Image Files"]    {.tiff .tif}    ] \
  36.     [list [mc "Image Files"]    {.xbm}        ] \
  37.     [list [mc "Image Files"]    {.xpm}        ] \
  38.     [list [mc "Image Files"]    {.ps .eps}        ] \
  39.     [list "BMP [mc Files]"        {.bmp}        ] \
  40.     [list "GIF [mc Files]"        {.gif}        ] \
  41.     [list "JPEG [mc Files]"        {.jpeg .jpg}    ] \
  42.     [list "PNG [mc Files]"        {.png}        ] \
  43.     [list "TIFF [mc Files]"        {.tiff .tif}    ] \
  44.     [list "XBM [mc Files]"        {.xbm}        ] \
  45.     [list "XPM [mc Files]"        {.xpm}        ] \
  46.     [list "Postscript [mc Files]"    {.ps .eps}        ] \
  47.     [list "GIF [mc Files]"        {}            GIFF] \
  48.     [list "JPEG [mc Files]"        {}            JPEG] \
  49.     [list "PNG [mc Files]"        {}            PNGF] \
  50.     [list "TIFF [mc Files]"        {}            TIFF] \
  51.     [list [mc {All files}]        *] \
  52. ]
  53.  
  54. proc Menu {base name} {
  55.     set menu [ConCat $base menu]
  56.     if {![winfo exists $menu]} {
  57.     menu $menu
  58.     $base configure -menu $menu
  59.     }
  60.     set accelerator [string toupper [string index $name 0]]
  61.     set text [mc "&$accelerator[string range $name 1 end]"]
  62.     set name $menu.$name
  63.     if {![winfo exists $name]} {
  64.     menu $name
  65.     $menu add cascade -label [mmc $text] -menu $name -underline [mml $text]
  66.     }
  67.     return $name
  68. }
  69.  
  70. #
  71. # Small proc to concatenate window pathnames
  72. #
  73. proc ConCat args {
  74.     regsub -all {[     \.]+} $args . args
  75.     return $args
  76. }
  77.  
  78. #
  79. #  Create a new image window
  80. #
  81.  
  82. proc image_window {{window {}}} {
  83.     global tkvPriv
  84.     if {![string compare $window {}]} {
  85.     set window .image$tkvPriv(count)
  86.     incr tkvPriv(count)
  87.     }
  88.     if {[winfo exists $window]} {
  89.     catch {eval destroy [winfo children $window]}
  90.     } else {
  91.     toplevel $window
  92.     }
  93.     wm title $window [mc {Viewer}]
  94.     set frame [ConCat $window frame]
  95.     label $frame -relief sunken -bg white -bd 2 -anchor nw
  96.     set w [Menu $window file]
  97.     $w configure -tearoff 0
  98.     set text [mc &Open]
  99.     $w add command -label [mmc $text] -command [list load_image $window] -underline [mml $text]
  100.     set text [mc &Save]
  101.     $w add command -label [mmc $text] -command [list save_image $window] -underline [mml $text]
  102.     $w add separator
  103.     set text [mc &Close]
  104.     $w add command -label [mmc $text] -command [list destroy $window] -underline [mml $text]
  105.     set text [mc E&xit]
  106.     $w add command -label [mmc $text] -command [list destroy .] -underline [mml $text]
  107.  
  108.     set w [Menu $window images]
  109.     set w [Menu $window help]
  110.     $w configure -tearoff 0
  111.     set text [mc &About]
  112.     $w add command -label [mmc $text] -command About -underline [mml $text]
  113.  
  114.     catch {wm geometry $window 200x200}
  115.     pack $frame -side top -expand y -fill both
  116.     return $frame
  117. }
  118.  
  119. proc register_image {w name} {
  120.     set menu [Menu $w images]
  121.     set item [file tail [lindex $name 0]]
  122.     if {[llength $name] > 1} {
  123.     append item " [lindex $name 1]"
  124.     }
  125.     $menu add command -label $item -command \
  126.     [list show_image $w $name]
  127. }
  128.  
  129. proc show_image {window name} {
  130.     [ConCat $window frame] configure -image $name
  131.     catch {wm geometry $window {}}
  132. }
  133.  
  134. proc load_image window {
  135.     global tkvPriv
  136.     set filename [tk_getOpenFile -filetypes $tkvPriv(types) -parent \
  137.         $window -initialdir $tkvPriv(currentdir)]
  138.     if {[string compare $filename {}]} {
  139.     set imagename [list $filename]
  140.     image create photo $imagename -file $filename
  141.     register_image $window $imagename
  142.     show_image $window $imagename
  143.     set tkvPriv(currentdir) [file dirname $filename]
  144.     }
  145. }
  146.  
  147. proc save_image window {
  148.     global tkvPriv
  149.     set img [[ConCat $window frame] cget -image]
  150.     set filename [tk_getSaveFile -filetypes $tkvPriv(types) -parent \
  151.         $window -initialdir $tkvPriv(currentdir) -defaultextension .gif \
  152.         -initialfile [file rootname [lindex $img 0]].gif]
  153.     if {[string compare $filename {}]} {
  154.     $img write $filename -format gif
  155.     set tkvPriv(currentdir) [file dirname $filename]
  156.     }
  157. }
  158.  
  159. proc About {} {
  160.     tk_dialog .about "[mmc [mc &About]] tkv.tcl" "[mc {Tiny Image viewer}]\n[mc {written by}]\
  161.         Jan Nijtmans <j.nijtmans@chello.nl>" {} 0 [mc O.K.]
  162. }
  163.  
  164. set w [lindex $argv 1]
  165. if {![string compare $w {}]} {
  166.     set w .
  167. }
  168. set filename [lindex $argv 0]
  169.  
  170. image_window $w
  171. if {[string compare $filename {}]} {
  172.     set imagename [list $filename]
  173.     image create photo $imagename -file $filename
  174.     register_image $w $imagename
  175.     show_image $w $imagename
  176. }
  177.