1#!/usr/bin/env tclsh 2 3package require Tk 8.4 4set noimg [catch {package require img::png}] ; # for saving images 5 6# We are the main script being run - show ourselves 7wm withdraw . 8 9package require widget::screenruler 10set dlg [widget::screenruler .r -title "Screen Ruler" -width 250 -height 100] 11 12if {[tk windowingsystem] eq "aqua"} { 13 set CTRL "Command-" 14 set CONTROL Command 15} else { 16 set CTRL Ctrl+ 17 set CONTROL Control 18} 19 20upvar \#0 [$dlg info vars reflect] reflect 21if {[lsearch -exact [image names] $reflect(image)] != -1} { 22 # We have a reflectable desktop 23 24 $dlg menu add separator 25 $dlg menu add command -label "Save Image" -accelerator ${CTRL}s \ 26 -underline 0 -command [list save $dlg] 27 bind $dlg <$CONTROL-s> [list save $dlg] 28} 29 30if {[tk windowingsystem] eq "x11"} { 31 # Add hack to control overrideredirect as some wms (eg KDE) have focus 32 # issues on the overrideredirect window 33 set override [expr {![wm overrideredirect $dlg]}] 34 $dlg menu add separator 35 $dlg menu add checkbutton -label "Window Decoration" -variable ::override \ 36 -command [list override $dlg] 37 proc override {w} { 38 wm withdraw $w 39 wm overrideredirect $w [expr {! $::override}] 40 wm deiconify $w 41 } 42 wm protocol $dlg WM_DELETE_WINDOW exit 43} 44 45$dlg menu add separator 46$dlg menu add command -label "Exit" \ 47 -underline 1 -accelerator ${CTRL}q -command { exit } 48bind $dlg <$CONTROL-q> { exit } 49 50package require comm 51$dlg menu add separator 52$dlg menu add command -label "COMM: [comm::comm self]" -state disabled 53 54focus -force $dlg 55$dlg display 56$dlg configure -alpha 0.8 57 58if {$::argc} { 59 eval [linsert $argv 0 $dlg configure] 60} 61 62set LASTDIR [pwd] 63 64proc save {dlg} { 65 global LASTDIR 66 variable [$dlg info vars reflect] 67 after cancel $reflect(id) 68 69 if {$::noimg} { 70 set filetypes { 71 {"All Image Files" {.gif .ppm}} 72 } 73 set re {\.(gif|ppm)$} 74 } else { 75 set filetypes { 76 {"All Image Files" {.gif .png .ppm}} 77 {"PNG Images" .png} 78 } 79 set re {\.(gif|ppm|png)$} 80 } 81 lappend filetypes {"GIF Images" .gif} {"PPM Images" .ppm} {"All Files" *} 82 set file [tk_getSaveFile -parent $dlg -title "Save Image to File" \ 83 -initialdir $LASTDIR -filetypes $filetypes] 84 85 if {$file ne ""} { 86 set LASTDIR [file dirname $file] 87 if {![regexp -nocase $re $file -> ext]} { 88 tk_messageBox -title "Unrecognized Extension" \ 89 -parent $dlg -icon error -type ok \ 90 -message "Unknown file type to save for file\ 91 \"[file tail $file]\"\nPlease use .gif, .ppm or .png." 92 } elseif {[catch {$reflect(image) write $file \ 93 -format [string tolower $ext]} err]} { 94 tk_messageBox -title "Error Writing File" \ 95 -parent $dlg -icon error -type ok \ 96 -message "Error writing to file \"$file\":\n$err" 97 } 98 } 99 100 $dlg configure -reflect [$dlg cget -reflect] 101} 102 103