TclTk - Divers exemples simples à comprendre
Rédigé par spheris
Aucun commentaire
Bonjour,
Aujourd'hui nous allons nous intéresser au langage interprété Tcl avec l'interface graphique Tk.
Ces outils nous permettent de créer de façon très simple et très rapide des interfaces pour linux, windows, mac et plein d'autre OS.
Introduction et pré requi.
Tout d'abord il vous faut installer le paquet Tcl pour utiliser le langage en ligne de commande.
Ensuite vous devez installer le paquet wish qui installera la dernière version de la librairie tk.
Pour exécuter les logiciels ci dessous, il vous suffit de copier le code source, le copier dans un fichier texte et l'enregistrer avec l'extention .tcl puis de l'exécuter en ligne de commande comme ceci :
wish myfile.tcl
A) Une calculatrice
Voici le code de l'application :
wm title . Calculator grid [entry .e -textvar e -just right] -columnspan 5 bind .e <Return> = set n 0 foreach row { {7 8 9 + -} {4 5 6 * /} {1 2 3 ( )} {C 0 . = } } { foreach key $row { switch -- $key { = {set cmd =} C {set cmd {set clear 1; set e ""}} default {set cmd "hit $key"} } lappend keys [button .[incr n] -text $key -command $cmd] } eval grid $keys -sticky we ;#-padx 1 -pady 1 set keys [list] } grid .$n -columnspan 2 ;# make last key (=) double wide proc = {} { regsub { =.+} $::e "" ::e ;# maybe clear previous result if [catch {set ::res [expr [string map {/ *1.0/} $::e]]}] { .e config -fg red } append ::e = $::res .e xview end set ::clear 1 } proc hit {key} { if $::clear { set ::e "" if ![regexp {[0-9().]} $key] {set ::e $::res} .e config -fg black .e icursor end set ::clear 0 } .e insert end $key } set clear 0 focus .e ;# allow keyboard input wm resizable . 0 0
B) Un calendrier
Voici le code de l'application :
#!/bin/sh # the next line restarts using wish exec wish "$0" "$@" # ------------------------------------------------------------------------------ # -- # -- calendar.tcl (Calendar for Linux/Unix & Windows) # -- # -- Copyright (C) 2004-2014 Stefan Euler # -- # -- This program is free software; you can redistribute it # -- and/or modify it under the terms of the GNU General Public # -- License as published by the Free Software Foundation; # -- either version 2 of the License, or (at your option) # -- any later version. # -- # -- This program is distributed in the hope that it will be # -- useful, but WITHOUT ANY WARRANTY; without even the implied # -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # -- PURPOSE. See the GNU General Public License for more details. # -- # -- You should have received a copy of the GNU General Public # -- License along with this program; if not, write to the Free # -- Software Foundation, Inc., 59 Temple Place, Suite 330, # -- Boston, MA 02111-1307, USA. # -- # ------------------------------------------------------------------------------ # -- # -- Usage : # -- calendar.tcl [winpos] [action on click] [show date] # -- # -- winpos = X and Y position for calendar window # -- (String of form '+100+150') # -- (defaults to '+200+150') # -- action on click = Action after selecting a date # -- 'close' -> Close window (exit 'calendar.tcl') # -- (= default) # -- 'hide' -> Hide window # -- 'icon' -> Iconify window # -- show date = open the month and year of the 'show date' # -- (String of form 'dd-mmm-yyyy') # -- (e.g. '02-Jul-2008') # -- # -- Output : # -- Cancel/Close : Empty string # -- Day button : Date string (dd.mm.yyyy) # -- # -- Keybindings : # -- Escape -> Close calendar (same as pressing 'Close' button) # -- Return -> Select active date (same as pressing day button) # -- Cursor up -> Go to the next month # -- Cursor down -> Go to the previous month # -- Cursor left -> Set active date to the previous day # -- Cursor right -> Set active date to the next day # -- Page up -> Go to the next year # -- Page down -> Go to the previous year # -- # ------------------------------------------------------------------------------ # -- # -- Last modified : 25-Mar-2014 # -- Version : 0.24 # -- Author : Stefan Euler # -- # ------------------------------------------------------------------------------ # -- global variables global tk_strictMotif; set tk_strictMotif 1 # ------------------------------------------------------------------------------ namespace eval CALENDAR { variable cal variable fheight variable htem variable os_type package require Tk set cal(col,0) "black" set cal(col,1) "white" set cal(col,2) "#e0e0e0" set cal(col,3) "#dfdfdf" set cal(col,4) "red" set cal(col,5) "blue" set cal(col,6) "#ffa0a0" set cal(col,7) "#ff2020" set cal(col,8) "#a0a0a0" set cal(sfont) -adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1 set cal(fheight) [font metrics $cal(sfont) -linespace] set cal(prg_vers) "V 0.24" set os_type $tcl_platform(platform) set cal(tcl,full) [info tclversion] set cal(tcl,maj) [lindex [split $cal(tcl,full) "."] 0] set cal(tcl,min) [lindex [split $cal(tcl,full) "."] 1] set cal(tcl,new) 0 if {$cal(tcl,maj) == 8} { if {$cal(tcl,min) >= 5} { set cal(tcl,new) 1 } } elseif {$cal(tcl,maj) > 8} { set cal(tcl,new) 1 } # -- ttk theme # set cal(ttk_theme) vista set cal(ttk_theme) aqua # -- Window size if {$tcl_platform(platform) == "windows"} { set cal(wsizex) 150 set cal(wsizey) 235 } else { set cal(wsizex) 180 set cal(wsizey) 230 } } # ------------------------------------------------------------------------------ # -- Procs # -- Check options proc CALENDAR::check_options { argv } { variable cal set opt_num [llength $argv] foreach argu $argv { if {$argu == "close" || $argu == "hide" || $argu == "icon"} { set cal(click) "$argu" } elseif {[string index $argu 0] == "+" || [string index $argu 0] == "-"} { set cal(winpos) "$argu" } else { if {$argu != ""} { set cal(sdate) "$argu" } } } return } # ------------------------------------------------------------------------------ # -- Initialize variables proc CALENDAR::init_all { args } { variable cal # -- Styles for ttk widgets ttk::style configure cal_days.TButton -background $cal(col,2) -foreground $cal(col,0) -font $cal(sfont) ttk::style configure cal_sat.TButton -background $cal(col,6) -foreground $cal(col,0) -font $cal(sfont) ttk::style configure cal_sun.TButton -background $cal(col,7) -foreground $cal(col,0) -font $cal(sfont) ttk::style configure cal_today.TButton -background $cal(col,5) -foreground $cal(col,5) -font $cal(sfont) ttk::style configure cal_active.TButton -background $cal(col,8) -foreground $cal(col,4) -font $cal(sfont) ttk::style configure cal_change.TButton -background $cal(col,2) -foreground $cal(col,0) -font $cal(sfont) -height 1 -padx 6 -pady 1 ttk::style configure cal_stand.TButton -background $cal(col,2) -foreground $cal(col,0) -font $cal(sfont) -height 1 ttk::style configure cal_stand.TFrame -background $cal(col,2) -relief ridge -borderwidth 2 -height $cal(fheight) ttk::style configure cal_flat.TFrame -background $cal(col,2) -relief flat -borderwidth 0 -height $cal(fheight) ttk::style configure cal_stand.TLabel -background $cal(col,2) -foreground $cal(col,0) -relief ridge -borderwidth 2 -height $cal(fheight) set cal(click) "close" set cal(winpos) "+200+150" # -- Get current date and define global calendar values set time [clock seconds] set cal(today) [clock format $time -format "%d-%b-%Y"] set cal(sdate) $cal(today) set month [string trimleft [clock format $time -format "%m"] 0] set year [clock format $time -format "%Y"] set cal(date) "$month/1/$year" set cal(dtext) [clock format [clock scan $cal(date)] -format "%B %Y"] return } # ------------------------------------------------------------------------------ # -- Exit calendar proc CALENDAR::exit_cal { args } { CALENDAR::Window destroy .cal exit } # ------------------------------------------------------------------------------ # -- Select the active date proc CALENDAR::select_active_date { args } { variable cal set selected_date [clock format [clock scan $cal(date)] -format "%d.%m.%Y"] puts "$selected_date" CALENDAR::select_action return } # ------------------------------------------------------------------------------ # -- Action after date selection proc CALENDAR::select_action { args } { variable cal if {$cal(click) == "close"} { CALENDAR::exit_cal } elseif {$cal(click) == "hide"} { CALENDAR::Window hide .cal } elseif {$cal(click) == "icon"} { CALENDAR::Window iconify .cal } return } # ------------------------------------------------------------------------------ # -- Display current time in 'HH:MM' format proc CALENDAR::set_time { win } { variable cal set time [clock seconds] set cal(today) [clock format $time -format "%b-%d-%Y"] if {$cal(tcl,new)} { set ctime [clock format $time -format "%H:%M" -timezone :localtime] } else { set ctime [clock format $time -format "%H:%M"] } append cal(today) " - $ctime" update after 1000 [list CALENDAR::set_time $win] return } # ------------------------------------------------------------------------------ # -- Change to current month proc CALENDAR::goto_today { win } { variable cal set time [clock seconds] set month [string trimleft [clock format $time -format "%m"] 0] set year [clock format $time -format "%Y"] set cal(date) "$month/1/$year" set cal(dtext) [clock format [clock scan $cal(date)] -format "%B %Y"] # -- Update calendar sheet CALENDAR::set_cal_sheet $win update return } # ------------------------------------------------------------------------------ # -- Change to month of 'show date' proc CALENDAR::goto_sdate { win } { variable cal set sdate_int [clock scan $cal(sdate)] set day [clock format $sdate_int -format "%d"] set month [string trimleft [clock format $sdate_int -format "%m"] 0] set year [clock format $sdate_int -format "%Y"] set cal(date) "$month/$day/$year" set cal(dtext) [clock format $sdate_int -format "%B %Y"] # -- Update calendar sheet CALENDAR::set_cal_sheet $win update return } # ------------------------------------------------------------------------------ # -- Display next (ri=+1) or previous (ri=-1) day, month or year proc CALENDAR::incr_dmy { what ri win } { variable cal set rich [expr $ri] set year [clock format [clock scan $cal(date)] -format "%Y"] set month [string trimleft [clock format [clock scan $cal(date)] -format "%m"] 0] set day [clock format [clock scan $cal(date)] -format "%d"] if {$cal(tcl,new)} { set nday [clock add [clock scan $cal(date)] $rich $what] } else { set nday [clock scan "$rich $what" -base [clock scan "$year-$month-$day"]] } set cal(date) [clock format $nday -format "%m/%d/%y"] set cal(dtext) [clock format [clock scan $cal(date)] -format "%B %Y"] # -- Update calendar sheet CALENDAR::set_cal_sheet $win update return } # ------------------------------------------------------------------------------ # -- Display days of the month and calendar weeks proc CALENDAR::set_cal_sheet { win } { variable cal variable htem # -- Check the current Tcl version set cal(tcl,new) 0 if {$cal(tcl,maj) == 8} { if {$cal(tcl,min) >= 5} { set cal(tcl,new) 1 } } elseif {$cal(tcl,maj) > 8} { set cal(tcl,new) 1 } set time [clock seconds] set now [clock format $time -format "%d.%m.%Y"] # -- Day of the active date set day [clock format [clock scan $cal(date)] -format "%d"] # -- Month of the active date set month [clock format [clock scan $cal(date)] -format "%m"] # -- Year of the active date set year [clock format [clock scan $cal(date)] -format "%Y"] # -- First day of the active month/year set cdate "$month/1/$year" # -- Active day set acday "$day.$month.$year" # -- Day of the week (1=Monday,...,7 or 0=Sunday) set wday [clock format [clock scan $cdate] -format "%u"] if {$wday == 0} { set wday 7 } incr wday # -- Effective current date for start of calendar sheet - 1 day set day_off [expr -1 * ($wday - 1)] if {$cal(tcl,new)} { set curr_date [clock add [clock scan $cdate] $day_off days] } else { set curr_date [clock scan $cdate] set curr_date "[expr $curr_date + ($day_off * 86400)]" } set c 0 foreach eintrag {"CW" "Mo" "Tu" "We" "Th" "Fr" "Sa" "Su"} { $win.fr_days.la_0$c configure -style cal_stand.TLabel -text "$eintrag" incr c } # -- Each line (calendar weeks) for {set r 1} {$r <= 6} {incr r} { set k 0 $win.fr_days.la_$r$k configure -text "11" # -- Each row (days of the week) for {set c 1} {$c <= 7} {incr c} { if {$cal(tcl,new)} { set curr_date [clock add $curr_date 1 day] } else { set curr_date [expr $curr_date + 86400] } set month2 [clock format $curr_date -format "%m"] if {$c == 1} { set kw [clock format $curr_date -format "%W"] $win.fr_days.la_$r$k configure -text "$kw" } if {$month2 == $month} { set day [string trimleft [clock format $curr_date -format "%d"] 0] set htem [clock format $curr_date -format "%d.%m.%Y"] if {$htem == $acday} { $win.fr_days.bu_$r$c configure -style cal_active.TButton } elseif {$htem == $now} { $win.fr_days.bu_$r$c configure -style cal_today.TButton } elseif {$c <= 5} { $win.fr_days.bu_$r$c configure -style cal_days.TButton } elseif {$c == 6} { $win.fr_days.bu_$r$c configure -style cal_sat.TButton } elseif {$c == 7} { $win.fr_days.bu_$r$c configure -style cal_sun.TButton } $win.fr_days.bu_$r$c configure -text "$day" -command "puts $CALENDAR::htem; CALENDAR::select_action" } elseif {$c >= 1} { $win.fr_days.bu_$r$c configure -style cal_days.TButton -text "" -command "" } } } CALENDAR::set_time $win return } # ------------------------------------------------------------------------------ # -- Check the window's position (should be completely inside screen) proc CALENDAR::check_win_pos { args } { variable cal variable os_type update # -- Get the X position set mxpos [lindex [split $cal(winpos) "+"] 1] set mypos [lindex [split $cal(winpos) "+"] 2] # -- Take care that the window is positioned within the screen set scr_width [winfo screenwidth .] set scr_height [winfo screenheight .] set win_width [winfo width .cal] set win_height [winfo height .cal] # -- Check the window's X position set wxpos [winfo x .cal] # -- stay at least within the screen area if {$wxpos < 0} { set wxpos 0 } elseif {[expr $wxpos + $win_width + 12] >= $scr_width} { set wxpos [expr $scr_width - $win_width - 12] } # -- Check the window's Y position set wypos [winfo y .cal] # -- stay at least within the screen area if {$wypos < 0} { set wypos 0 } elseif {[expr $wypos + $win_height + 60] >= $scr_height} { set wypos [expr $scr_height - $win_height - 60] } set cal(winpos) "+$wxpos+$wypos" if {$os_type == "windows"} { set pos "[expr [winfo width .cal.fr_days] + 40]" append pos "x$cal(wsizey)" append pos "$cal(winpos)" } else { set pos "[expr [winfo width .cal.fr_days] + 40]" append pos "x$cal(wsizey)" append pos "$cal(winpos)" } wm geometry .cal "$pos" return } # ------------------------------------------------------------------------------ # -- Window procedur proc CALENDAR::Window { args } { set cmd [lindex $args 0] set name [lindex $args 1] set newname [lindex $args 2] set rest [lrange $args 3 end] if {$name == "" || $cmd == ""} { return } if {$newname == ""} { set newname $name } set exists [winfo exists $newname] switch $cmd { show { if {$exists == "1" && $name != "."} { wm deiconify $name return } if {[info procs calWindow(pre)$name] != ""} { eval "calWindow(pre)$name $newname $rest" } if {[info procs calWindow$name] != ""} { eval "calWindow$name $newname $rest" } if {[info procs calWindow(post)$name] != ""} { eval "calWindow(post)$name $newname $rest" } } hide { if $exists { wm withdraw $newname return } } iconify { if $exists { wm iconify $newname return } } destroy { if $exists { destroy $newname return } } } return } # ------------------------------------------------------------------------------ # -- Root Window for Calendar proc CALENDAR::calWindow. { base } { if {$base == ""} { set base . } wm focusmodel $base passive wm geometry $base 1x1+0+0 wm maxsize $base 1137 834 wm minsize $base 1 1 wm overrideredirect $base 0 wm resizable $base 1 1 wm withdraw $base wm title $base "eu_calendar.tcl" return } # ------------------------------------------------------------------------------ # -- Calendar window proc CALENDAR::calWindow.cal { base } { global glob_var variable cal variable os_type if {$base == ""} { set base .cal } if {[winfo exists .cal]} { wm deiconify .cal return } toplevel $base -class Toplevel -background $cal(col,2) wm focusmodel $base passive if {$os_type == "windows"} { set pos "$cal(wsizex)" append pos "x$cal(wsizey)" append pos "$cal(winpos)" } else { set pos "$cal(wsizex)" append pos "x$cal(wsizey)" append pos "$cal(winpos)" } wm geometry $base $pos wm maxsize $base 400 400 wm minsize $base 1 1 wm overrideredirect $base 0 wm resizable $base 0 0 wm deiconify $base wm title $base "CALENDAR" wm protocol $base WM_DELETE_WINDOW {puts ""; CALENDAR::exit_cal} # -- Header frame with month and buttons to move in months and years set fr_month [ttk::frame $base.fr_month -style cal_stand.TFrame -relief flat] set yd_month [ttk::button $base.fr_month.bu_ydown -style cal_change.TButton -text "<<" -width 2 -command "CALENDAR::incr_dmy years -1 $base"] set md_month [ttk::button $base.fr_month.bu_mdown -style cal_change.TButton -text "<" -width 1 -command "CALENDAR::incr_dmy months -1 $base"] set la_month [ttk::label $base.fr_month.la_month -foreground $cal(col,0) -background $cal(col,2) -borderwidth 1 -relief ridge -textvariable CALENDAR::cal(dtext) -font $cal(sfont) -anchor c] if {$os_type == "windows"} { $base.fr_month.la_month configure -relief flat } set mu_month [ttk::button $base.fr_month.bu_mup -style cal_change.TButton -text ">" -width 1 -command "CALENDAR::incr_dmy months +1 $base"] set yu_month [ttk::button $base.fr_month.bu_yup -style cal_change.TButton -text ">>" -width 2 -command "CALENDAR::incr_dmy years +1 $base"] # -- Bottom frame with current date set fr_bottom [ttk::frame $base.fr_today -style cal_stand.TFrame] set la1_bottom [ttk::label $base.fr_today.la_today -foreground $cal(col,0) -background $cal(col,2) -borderwidth 0 -relief flat -text "Today :" -width 7 -font $cal(sfont) -anchor w] set la2_bottom [ttk::label $base.fr_today.la_todat -foreground $cal(col,0) -background $cal(col,2) -borderwidth 0 -relief flat -textvariable CALENDAR::cal(today) -width 20 -font $cal(sfont) -anchor w] # -- Frame with 'Close' button set fr_close [ttk::frame $base.fr_close -style cal_stand.TFrame] set bu_close [ttk::button $base.fr_close.bu_close -style cal_stand.TButton -text "Close" -command { puts "" CALENDAR::exit_cal }] # -- Frame for days set fr_days [ttk::frame $base.fr_days -style cal_flat.TFrame] # -- Header (CW, Mo, Tu, We, Th, Fr, Sa, Su) if {$os_type == "windows"} { set ypad 4 } else { set ypad 1 } set c 0 foreach eintrag {"CW" "Mo" "Tu" "We" "Th" "Fr" "Sa" "Su"} { ttk::label $base.fr_days.la_0$c -style cal_stand.TLabel -text "$eintrag" -font $cal(sfont) -anchor c incr c } # -- Define 6 * 8 buttons for {set r 1} {$r <= 6} {incr r} { set c 0 ttk::label $base.fr_days.la_$r$c -style cal_stand.TLabel -text "11" -width 2 -font $cal(sfont) -anchor c for {set c 1} {$c <= 7} {incr c} { ttk::button $base.fr_days.bu_$r$c -style cal_days.TButton -width 2 -text "" -command "" if {$c == 6} { $base.fr_days.bu_$r$c configure -style cal_sat.TButton } if {$c == 7} { $base.fr_days.bu_$r$c configure -style cal_sun.TButton } } } # -- Display header frame (<< < MONTH > >>) pack $base.fr_month -anchor c -expand 0 -fill x -side top -padx 2 -ipadx 2 -ipady 2 pack $base.fr_month.bu_ydown -side left pack $base.fr_month.bu_mdown -side left pack $base.fr_month.bu_yup -side right pack $base.fr_month.bu_mup -side right pack $base.fr_month.la_month -side left -expand 1 -fill x # -- Display frame with 'Close' button pack $base.fr_close -anchor c -expand 0 -fill x -side bottom -padx 2 -ipadx 2 -ipady 2 pack $base.fr_close.bu_close -padx 2 -anchor c -expand 1 -fill x -side left # -- Display bottom frame with current date pack $base.fr_today -anchor c -expand 0 -fill x -side bottom -padx 2 -ipadx 2 -ipady 2 pack $base.fr_today.la_today -anchor center -expand 0 -fill none -side left -padx 2 pack $base.fr_today.la_todat -anchor center -expand 0 -fill none -side left -padx 2 # -- Display frame with days pack $base.fr_days -anchor c -expand 1 -fill both -side left -padx 2 -ipadx 2 -ipady 2 grid rowconfig $base.fr_days all -weight 1 grid columnconfig $base.fr_days all -weight 1 # -- Display header (CW, Mo, Tu, We, Th, Fr, Sa, Su) for {set c 0} {$c <= 7} {incr c} { grid $base.fr_days.la_0$c -row 0 -column $c -columnspan 1 -rowspan 1 -ipadx 2 -ipady 2 -sticky nsew } # -- Display 6 * 8 buttons for {set r 1} {$r <= 6} {incr r} { set c 0 grid $base.fr_days.la_$r$c -row $r -column $c -rowspan 1 -columnspan 1 -ipadx 2 -ipady 2 -sticky nsew for {set c 1} {$c <= 7} {incr c} { grid $base.fr_days.bu_$r$c -row $r -column $c -rowspan 1 -columnspan 1 -ipadx 0 -ipady 0 -sticky nsew } } # -- Bindings bind $base.fr_today <ButtonRelease-1> "CALENDAR::goto_today $base" bind $base.fr_today.la_today <ButtonRelease-1> "CALENDAR::goto_today $base" bind $base.fr_today.la_todat <ButtonRelease-1> "CALENDAR::goto_today $base" bind $base <KeyRelease-Prior> "CALENDAR::incr_dmy years +1 $base" bind $base <KeyRelease-Next> "CALENDAR::incr_dmy years -1 $base" bind $base <KeyRelease-Up> "CALENDAR::incr_dmy months +1 $base" bind $base <KeyRelease-Down> "CALENDAR::incr_dmy months -1 $base" bind $base <KeyRelease-Left> "CALENDAR::incr_dmy days -1 $base" bind $base <KeyRelease-Right> "CALENDAR::incr_dmy days +1 $base" bind $base <KeyRelease-Home> "CALENDAR::goto_today $base" bind $base <KeyRelease-Escape> "$base.fr_close.bu_close invoke" bind $base <KeyRelease-Return> "CALENDAR::select_active_date" # ttk::setTheme $cal(ttk_theme) return } # ------------------------------------------------------------------------------ CALENDAR::init_all CALENDAR::check_options $argv CALENDAR::Window show . CALENDAR::Window show .cal CALENDAR::check_win_pos CALENDAR::goto_sdate .cal
C) Une horloge analogique
Voici le code source :
# Cadran d'horloge de Wolf-Dieter Busch (http://wiki.tcl.tk/1011) ... v. 1.8.2 - Sept 2010 # Avec quelques modifications cosmétiques : # Redimensionnement, graduations, transparence, paramétrage. # S'il trouve couleurs/vuecouleurs.tcl (noms de couleurs reconnus par tk) ou tcllib ::math::roman (chiffres romains), le script les utilise. # substexpands.tcl & hwdboptx.tcl permettent de personaliser les paramètres mais ne sont pas indispensables pour une utilisation régulière. # http://tratoxic.free.fr/t/tk.htm#scripts package require Tk # Variables utilisateur, voir aussi les dimensions dans la proc. initialisations. set hwdb(couleur_cadran) {old lace} set hwdb(couleur_chiffres) peru set hwdb(couleur_aiguilles) peru set hwdb(couleur_sec) chocolate4 set hwdb(couleur_ombres) gray83 set hwdb(format_titre) {%Okh%M %A %x} set hwdb(opacite) 1. ;# Un moins transparence (float [0:1]) set hwdb(electrique) 1 ; ;# 1 => saut à chaque minute, 0 => mécanique : sans à-coup (aiguille des minutes uniquement) set hwdb(premier_plan) 0 ;# topmost set hwdb(fond_transparent) 0 ;# ... Mais cadran visible. Sauf erreur de ma part, "wm aspect" n'est pas fonctionnel sous win xp, d'où set hwdb(bordure_systeme) 4 ;# la réalisation "en dur" de la configuration du rapport largeur/hauteur dans la proc autre_taille_cadran, set hwdb(delai_configure) 10 ;# avec un délai 5<d<50 ms limitant les ressources utilisées par le script lors des évennements "Configure". set hwdb(ombre_chiffres) 1 # Variables internes set hwdb(script) [winfo name .] set hwdb(config_en_cours) 0 ;# Sémaphore pour section exclusive (non ré-entrance dans la proc autre_taille_cadran) set hwdb(PI) [expr {acos(-1)}] set hwdb(romains) 0 ;# 0 : pour chiffres indo-arabes au démarrage. 1 : romains, n'agit qu'en présence de tcllib math::roman. set hwdb(noms_couleurs_tk) 0 ;# 0 : choix par la boîte standard -> valeur #rvb, 1 : choix avec vuecouleurs.tcl -> nom. set hwdb(console) 0 # Variables utilisateur proportionnelles aux dimensions du cadran de l'horloge, l'argument par défaut est le rayon au départ (float). # Sauf l'avant dernière, ces variables pourraient rester float. Elles sont castées int pour des raisons de performance. proc initialisations {{r 120.}} { global hwdb set hwdb(rayon) $r ;#demi-largeur du canvas conteneur (= coordonnées x=y du centre) set hwdb(bordure_cadran) [expr {int($r * .05)}] ;# marges entre le cadran et le bord du canvas set hwdb(rayon_chiffres) [expr {int($r * .83)}] set hwdb(rayon_graduations) [expr {int($r * .91)}] set hwdb(longueur_aiguille_sc) [expr {int($r * .85)}] set hwdb(longueur_aiguille_mn) [expr {int($r * .75)}] set hwdb(longueur_aiguille_hr) [expr {int($r * .60)}] set hwdb(largeur_aiguille_sc) [expr {int($r * .02)}] set hwdb(largeur_aiguille_mn) [expr {int($r * .05)}] set hwdb(largeur_aiguille_hr) [expr {int($r * .08)}] set hwdb(distance_ombre_sc) [expr {int($r * .035)}] set hwdb(distance_ombre_mn) [expr {int($r * .03)}] set hwdb(distance_ombre_hr) [expr {int($r * .025)}] set hwdb(police) "Helvetica [expr {int($r * .13)}] bold" set hwdb(rpgm) [expr {int($r / 80)}] ;# rayon d'un point de graduation des minutes return } # Détermine la forme des pointes de flêche d'aiguille. # La ligne en commentaire, "*2", "1.6" sont utilisés par la proc change_fleche dans hwdboptx.tcl proc fleche largeur { # return "[set a [expr {$largeur*2}]] $a [expr {$largeur/2}]" return "[set a [expr {int($largeur*1.6)}]] $a 1" } # Dessine le tout : Cadran, graduations, aiguilles et chiffres. proc dessine_le_tout {} { global hwdb set r $hwdb(rayon) # cadran set mbd [expr {2 * $r - $hwdb(bordure_cadran)}] ; # marge en bas et à droite .c create oval $hwdb(bordure_cadran) $hwdb(bordure_cadran) $mbd $mbd -fill $hwdb(couleur_cadran) -outline {} -tag cadran # graduations (12 x 4 points, sans le "if $i %5" pour 60 points) set rp [expr int($hwdb(rpgm))] for {set i 0} {$i < 60} {incr i} { if {[expr {$i % 5}]} { set a [expr {$hwdb(PI) / 30 * (30 - $i)}] set x [expr {int( sin( $a ) * $hwdb(rayon_graduations) + $hwdb(rayon) )}] set y [expr {int( cos( $a ) * $hwdb(rayon_graduations) + $hwdb(rayon) )}] if {$r < 100} { .c create line $x $y [incr x] [incr y] -tag graduations -fill $hwdb(couleur_sec) ;# 1 point } else { .c create oval [expr {$x - $rp}] [expr {$y - $rp}] [incr x $rp] [incr y $rp] -tag graduations -fill $hwdb(couleur_sec) -outline {} } } } # chiffres for {set i 1} {$i <= 12} {incr i} { set a [expr {$hwdb(PI) / 6 * (6 - $i)}] set x [expr {sin( $a ) * $hwdb(rayon_chiffres) + $r}] set y [expr {cos( $a ) * $hwdb(rayon_chiffres) + $r}] set t [expr {$hwdb(romains) ? [::math::roman::toroman $i] : $i }] if $hwdb(ombre_chiffres) {.c create text [expr {$x+$hwdb(distance_ombre_hr)/1.5}] [expr {$y+$hwdb(distance_ombre_hr)/1.5}] -text $t -font $hwdb(police) -fill $hwdb(couleur_ombres) -tag ombre_chiffres} .c create text $x $y -text $t -font $hwdb(police) -fill $hwdb(couleur_chiffres) -tag chiffres } # aiguilles au dessus de leurs ombres, axe de la trotteuse qui masque le bout carré des aiguilles h et mn (tracé initial de WDB à 3h00mn30s). .c create line $r $r [expr {$r + $hwdb(longueur_aiguille_hr)}] $r -tag ombre_hr -width $hwdb(largeur_aiguille_hr) -fill $hwdb(couleur_ombres) -arrow last -arrowshape [fleche $hwdb(largeur_aiguille_hr)] .c create line $r $r $r [expr {$r - $hwdb(longueur_aiguille_mn)}] -tag ombre_mn -width $hwdb(largeur_aiguille_mn) -fill $hwdb(couleur_ombres) -arrow last -arrowshape [fleche $hwdb(largeur_aiguille_mn)] .c create line $r $r $r [expr {$r + $hwdb(longueur_aiguille_sc)}] -tag ombre_sc -width $hwdb(largeur_aiguille_sc) -fill $hwdb(couleur_ombres) -arrow last -arrowshape [fleche $hwdb(largeur_aiguille_sc)] .c create line $r $r [expr {$r + $hwdb(longueur_aiguille_hr)}] $r -tag aiguille_hr -width $hwdb(largeur_aiguille_hr) -fill $hwdb(couleur_aiguilles) -arrow last -arrowshape [fleche $hwdb(largeur_aiguille_hr)] .c create line $r $r $r [expr {$r - $hwdb(longueur_aiguille_mn)}] -tag aiguille_mn -width $hwdb(largeur_aiguille_mn) -fill $hwdb(couleur_aiguilles) -arrow last -arrowshape [fleche $hwdb(largeur_aiguille_mn)] if {$hwdb(largeur_aiguille_sc) > $hwdb(largeur_aiguille_mn)} {set amx $hwdb(largeur_aiguille_sc)} else {set amx $hwdb(largeur_aiguille_mn)} if {$hwdb(largeur_aiguille_hr) > $amx} {set amx $hwdb(largeur_aiguille_hr)} set hg [expr {$r - $amx / 2}] ; set ohg [expr {$hg + $hwdb(distance_ombre_sc)}] set bd [expr {$r + $amx / 2}] ; set obd [expr {$bd + $hwdb(distance_ombre_sc)}] .c create oval $hg $hg $bd $bd -outline {} -fill $hwdb(couleur_sec) -tag axe .c create oval $ohg $ohg $obd $obd -outline {} -fill $hwdb(couleur_ombres) -tag ombre_axe .c create line $r $r $r [expr {$r + $hwdb(longueur_aiguille_sc)}] -tag aiguille_sc -width $hwdb(largeur_aiguille_sc) -fill $hwdb(couleur_sec) -arrow last -arrowshape [fleche $hwdb(largeur_aiguille_sc)] foreach i {ombre_axe ombre_hr ombre_mn ombre_sc} {.c lower $i graduations} return } # Rotation d'un angle a d'une aiguille et de son ombre spécifiées par leur tag d'une quantité # n d'unités (hr, mn, sec). Fournir aussi la longueur de l'aiguille et la distance avec son ombre. proc tourne_aiguille {tag_aig tag_omb n longueur d_omb} { global hwdb switch $tag_aig {aiguille_hr {set div 6} aiguille_mn {set div 30} aiguille_sc {set div 30}} set a [expr {$hwdb(PI) * ($div - $n) / $div}] set x [expr {$hwdb(rayon) + sin($a) * $longueur}] set y [expr {$hwdb(rayon) + cos($a) * $longueur}] .c coords $tag_aig $hwdb(rayon) $hwdb(rayon) $x $y set oc [expr {$hwdb(rayon) + $d_omb}] .c coords $tag_omb $oc $oc [expr {$x + $d_omb}] [expr {$y + $d_omb}] return } # Procédure auto-entretenue qui fait tourner les aiguilles. # Les aiguilles des heures et minutes sont positionnées quand un nouveau cadran est dessiné, ou seulement une fois par minute. # Cas particulier : mécanique, l'aiguille des mn avance à chaque seconde. proc une_fois_par_seconde {{init 0}} { global hwdb set hwdb(timer) [after 1000 une_fois_par_seconde] set secs [clock seconds] set l [clock format $secs -format {%H %M %S}] set hrs [regsub ^0 [lindex $l 0] {}] set min [regsub ^0 [lindex $l 1] {}] set sec [regsub ^0 [lindex $l 2] {}] set hrs [expr {$hrs + $min/60.}] if {$init || (!$sec && ![wm overrideredirect .])} { wm title . [clock format $secs -format $hwdb(format_titre) -locale current] } tourne_aiguille aiguille_sc ombre_sc $sec $hwdb(longueur_aiguille_sc) $hwdb(distance_ombre_sc) if $init { tourne_aiguille aiguille_mn ombre_mn $min $hwdb(longueur_aiguille_mn) $hwdb(distance_ombre_mn) tourne_aiguille aiguille_hr ombre_hr $hrs $hwdb(longueur_aiguille_hr) $hwdb(distance_ombre_hr) return } if !$hwdb(electrique) { tourne_aiguille aiguille_mn ombre_mn [expr {$min + $sec/60.}] $hwdb(longueur_aiguille_mn) $hwdb(distance_ombre_mn) } else { if !$sec {tourne_aiguille aiguille_mn ombre_mn $min $hwdb(longueur_aiguille_mn) $hwdb(distance_ombre_mn)} } if !$sec {tourne_aiguille aiguille_hr ombre_hr $hrs $hwdb(longueur_aiguille_hr) $hwdb(distance_ombre_hr)} return } # Basculements entre fenêtre sans et avec le cadre du système d'exploitation. # Le titre n'étant mis à jour qu'à chaque minute (secondes = 0), "avec cadre" se fait avec titre, sans transparence. # Le cadre supprimé, ombres et cadran deviennent transparents. proc toggle_visu {} { global hwdb ;# s'il n'y a pas de cadre, on le remet : if [wm overrideredirect .] { wm title . [clock format [clock seconds] -format $hwdb(format_titre) -locale current] wm overrideredirect . 0 wm attributes . -transparentcolor {} -alpha 1 .c itemconfigure cadran -fill $hwdb(couleur_cadran) if $hwdb(ombre_chiffres) {.c itemconfigure ombre_chiffres -fill $hwdb(couleur_ombres)} foreach i {ombre_hr ombre_mn ombre_sc ombre_axe} { .c itemconfigure $i -fill $hwdb(couleur_ombres) } } else { set c [.c cget -background] ;# la couleur du fond devient la "couleur transparente" wm overrideredirect . 1; wm withdraw .; wm deiconify . ;# on/off : pour les systèmes qui ne réagiraient pas, cf. doc. tk wm attributes . -transparentcolor $c -alpha $hwdb(opacite) update if $hwdb(ombre_chiffres) {.c itemconfigure ombre_chiffres -fill $c} foreach i {cadran ombre_hr ombre_mn ombre_sc ombre_axe} { .c itemconfigure $i -fill $c } } return } # Arrête le temporisateur le temps d'effacer tout et de redessiner, puis le redémarre. proc stop_change_redemarre {} { global hwdb after cancel $hwdb(timer) set rayon [expr {[set largeur [scan [wm geometry .] %f]] / 2.}] if $hwdb(ombre_chiffres) {.c delete ombre_chiffres} .c delete aiguille_sc ombre_axe axe aiguille_mn aiguille_hr ombre_sc ombre_mn ombre_hr chiffres graduations cadran initialisations $rayon .c configure -width $largeur -height $largeur if [wm overrideredirect .] {set c $hwdb(couleur_cadran) ; set hwdb(couleur_cadran) [.c cget -background]} dessine_le_tout if [wm overrideredirect .] {set hwdb(couleur_cadran) $c} une_fois_par_seconde 1 } # Dans une section non ré-entrante ... Si la largeur n'a pas changé, force une fenêtre carrée quand ce n'est pas le cas, # sinon fait redessiner le tout. proc autre_taille_cadran {} { global hwdb if $hwdb(config_en_cours) return ;# limite le nombre de réactions devant l'avalanche d'évennements "Configure" incr hwdb(config_en_cours) set g [split [wm geometry .] x+] set l [lindex $g 0] set h [lindex $g 1] set m [expr {($l > $h) ? $l : $h}] if {$m == [expr {2 * int($hwdb(rayon))}]} { if {$l != $h} {wm geometry . $mx$m ; update} ;# force une fenêtre carrée after $hwdb(delai_configure) set hwdb(config_en_cours) 0 return } if {$m > [winfo screenwidth .]} {set m [winfo screenwidth .]} ;# limitation : dans l'écran if {$m > [winfo screenheight .]} {set m [winfo screenheight .]} wm geometry . $mx$m ;# force une fenêtre carrée update if [winfo exist .o.f.f] {.o.f.f set $hwdb(rpgm)} ;# fait suivre le rayon des graduations dans hwdboptx.tcl. stop_change_redemarre if [winfo exist .o.f] elements_optx ;# évite que les curseurs aillent en butée en agrandissant le cadran dans hwdboptx.tcl. after $hwdb(delai_configure) set hwdb(config_en_cours) 0 return } # Fournit l'opposée d'une valeur #rvb quelqu'en soit la taille. proc diese_complementaire rvb { for {set i 1; set v #; set s [string length $rvb]} {$i < $s} {incr i} { append v [format %01x [expr {15 ^ [scan [string index $rvb $i] %x]}]] } return $v } # Boîte de choix de couleur d'un élément par l'utilisateur. # Limite à une seule boîte par élément en inhibant son bouton. proc choix_couleur {item bouton} { global hwdb $bouton config -state disabled if $hwdb(noms_couleurs_tk) { if [winfo exist .topvcoul] {$bouton config -state normal; focus .topvcoul; return} set ::dim $hwdb(couleur_$item) uplevel source couleurs/vuecouleurs.tcl tkwait window .topvcoul if [catch {clipboard get} choix] {set choix {}} else {set choix [string trim $choix {}]} } else { set choix [tk_chooseColor -initialcolor $hwdb(couleur_$item) -title "couleur $item"] } if {$choix == {}} {$bouton config -state normal; return} set hwdb(couleur_$item) $choix switch $item { aiguilles {set items {aiguille_hr aiguille_mn}} sec {set items {aiguille_sc axe graduations}} ombres {set items {ombre_axe ombre_sc ombre_mn ombre_hr} ; if $hwdb(ombre_chiffres) {lappend items ombre_chiffres}} default {set items $item} } foreach i $items {.c itemconfigure $i -fill $choix} $bouton config -bg $choix -state normal -text "[lindex [$bouton cget -text] 0] $choix" if {[string index $choix 0] == {#}} {$bouton config -fg [diese_complementaire $choix]} else {$bouton config -fg $hwdb(couleur_texte_bouton)} return } # Boîte de changement des paramètres par l'utilisateur. # Les options "chiffres romains" et nom de couleur reconnues par tk n'apparaissent que si les libs idoines sont installées. proc options {} { global hwdb set hwdb(config_en_cours) 1 if [winfo exists .o] {destroy .o; update ; set hwdb(config_en_cours) 0 ; return} toplevel .o wm title .o "options $hwdb(script)" frame .o.g ; frame .o.d label .o.g.a -text {format de la date} label .o.g.b -text {opacité} label .o.g.c -text {délai de redimensionnement} # label .o.g.c -text {épaisseur du cadre système} if [file readable couleurs/vuecouleurs.tcl] { checkbutton .o.g.d -text {couleur tk proche} -variable hwdb(noms_couleurs_tk) } else { label .o.g.d -text {} set hwdb(noms_couleurs_tk) 0 } button .o.g.e -text "cadran $hwdb(couleur_cadran)" -command {choix_couleur cadran .o.g.e} -bg $hwdb(couleur_cadran) button .o.g.f -text "ombres $hwdb(couleur_ombres)" -command {choix_couleur ombres .o.g.f} -bg $hwdb(couleur_ombres) button .o.g.g -text "aiguilles $hwdb(couleur_aiguilles)" -command {choix_couleur aiguilles .o.g.g} -bg $hwdb(couleur_aiguilles) button .o.g.h -text "trotteuse $hwdb(couleur_sec)" -command {choix_couleur sec .o.g.h} -bg $hwdb(couleur_sec) button .o.g.i -text "chiffres $hwdb(couleur_chiffres)" -command {choix_couleur chiffres .o.g.i} -bg $hwdb(couleur_chiffres) entry .o.d.a -textvariable hwdb(format_titre) -justify center spinbox .o.d.b -textvariable hwdb(opacite) -justify center -increment .05 -from 0. -to 1.05 -validate key -vcmd {catch {wm attributes . -alpha $hwdb(opacite)} ; string is double %P} spinbox .o.d.c -textvariable hwdb(delai_configure) -justify center -increment 10 -from 10 -to 500 -validate key -vcmd {string is integer %P} # spinbox .o.d.c -textvariable hwdb(bordure_systeme) -justify center -increment 1 -from 0 -to 20 -validate key -vcmd {string is integer %P} checkbutton .o.d.d -text {au premier plan} -variable hwdb(premier_plan) -command {wm attributes . -topmost $hwdb(premier_plan)} checkbutton .o.d.e -text {fond transparent} -variable hwdb(fond_transparent) -command {wm attributes . -transparentcolor [expr {$hwdb(fond_transparent) ? [.c cget -bg] : {}}]} if ![catch {package require math::roman}] { checkbutton .o.d.f -text {chiffres romains} -variable hwdb(romains) -command stop_change_redemarre } else { label .o.d.f -text {} } radiobutton .o.d.g -text {électrique (mn) } -value 1 -variable hwdb(electrique) radiobutton .o.d.h -text {mécanique (mn)} -value 0 -variable hwdb(electrique) checkbutton .o.d.i -text console -variable hwdb(console) -command { if $hwdb(console) { set tcl_prompt1 {puts -nonewline [history nextid] [file nativename [pwd]]> } catch {console title "console $hwdb(script)" ; console show} } else { unset tcl_prompt1 catch {console hide} } } set hwdb(couleur_texte_bouton) [.o.g.a cget -fg] bind .o.d.a <Return> {wm title . [clock format [clock seconds] -format $hwdb(format_titre) -locale current]} bind .o <F1> {tk_messageBox -title options $hwdb(script) -type ok -message " "couleur proche tk" : Choix d'un nom de couleur reconnu par tk plutôt que d'une valeur #rvb,n "mécanique" : L'aiguille des minutes progresse chaque seconde." ; focus .o} bind .o <Escape> {destroy .o} pack .o.g.a .o.g.b .o.g.c .o.g.d .o.g.e .o.g.f .o.g.g .o.g.h .o.g.i -side top -anchor nw -pady 4 -fill x pack .o.d.a .o.d.b .o.d.c .o.d.d .o.d.e .o.d.f .o.d.g .o.d.h .o.d.i -side top -anchor nw -pady 5 -fill x pack .o.g .o.d -side left -anchor nw -expand 1 -fill x if {[file readable substexpands.tcl] && [file readable hwdboptx.tcl]} {source hwdboptx.tcl} wm resizable .o 0 0 focus .o set hwdb(config_en_cours) 0 return } initialisations pack [canvas .c -width [expr {2 * $hwdb(rayon)}] -height [expr {2 * $hwdb(rayon)}]] -fill both -expand 1 dessine_le_tout update idletasks wm geometry . +[expr {[winfo screenwidth .] - [winfo reqwidth .] - 2 * $hwdb(bordure_systeme)}]+0 ;# à droite et en haut de l'écran wm protocol . WM_DELETE_WINDOW {after cancel $hwdb(timer); destroy .} ;# stoppe la temporisation auto-entretenue à la fermeture bind . <Alt-x> {destroy .} ; bind . <Control-q> {destroy .} ; bind . <Control-d> {destroy .} ; bind . <Control-c> {destroy .} bind . <F1> {tk_messageBox -title $hwdb(script) http://tratoxic.free.fr/t/tk.htm#scripts -type ok -message {Répond aux clics souris (droite ou gauche) dans les zones affichées}} bind .c <3> options bind .c <1> toggle_visu bind . <Configure> autre_taille_cadran une_fois_par_seconde 1 focus -force . # Bogues et limites : # L'affichage des ombres n'est pas indépendant. Pour en voir dans l'état transparent, il faut appeler les options # depuis cet état transparent. Parmi les 4 états possibles de transparence, deux sont plutôt des effets de bord. # Trotteuse et graduations ont la même couleur, ainsi que les aiguilles des heures et des minutes. # Opacité jusqu'à 1.05 fleure bon la compensation de bogue. # Dans la proc. choix_couleur, l'usage de vuecouleurs.tcl phagocite le contenu du presse-papiers. # Non, le script ne se modifie pas lui-même pour garder de nouveaux paramètres optionnels ! "parray hwdb" dans la console ? # L'étape suivante, un cadran ovale ? avec aiguilles qui changent de longueur au fil du temps :) # P.S. "Dessine moi un mouton !" Euh, j' sais pas dessiner les moutons, tu veux pas plutôt un cadran d'horloge ?
D) Un explorateur de fichiers
voici le code :
package require Tk global tcl_platform if {$tcl_platform(platform) == "windows"} { package require registry package require opt } else { package require opt } wm resizable . 0 0 wm title . "TkMC v1.0" ###################################### #Disable default Error messages proc bgerror {errmsg} { global errorInfo errorCode set msg [format "Error: %s." $errmsg $errorCode] tk_messageBox -parent . -title "Error" -type ok -icon error -message $msg } ######################### #Proc centering windows proc center_win {w} { set x [expr [winfo rootx .]+250] set y [expr [winfo rooty .]+150] wm geometry $w "+$x+$y" } ############################### #Proc entry history namespace eval history { proc add? {w} { variable $w variable n$w upvar 0 $w hist set s [set ::[$w cget -textvariable]] if {$s == ""} return if [string compare $s [lindex $hist end]] { lappend hist $s set n$w [llength $hist] } } proc move {w where} { variable $w variable n$w upvar 0 $w hist incr n$w $where if {[set n$w]<0} {set n$w 0} if {[set n$w]>=[llength $hist]+1} { set n$w [llength $hist] } set ::[$w cget -textvar] [lindex $hist [set n$w]] } proc for {type name args} { switch -- $type { entry { uplevel $type $name $args bind $name <Up> {history::move %W -1} bind $name <Down> {history::move %W 1} bind $name <Next> {history::move %W 99999} bind $name <Return> {history::add? %W} variable $name {} variable n$name 0 } default {error "usage: history::for entry <w> <args>"} } } } ############################## frame .top frame .top.f -relief groove -bd 2 pack .top.f -fill x -expand true -side left foreach x [file volume] { button .top.f.f$x -text [file native $x] -font {arial 8 {bold} } -relief groove -command "" pack .top.f.f$x -side left .top.f.f$x config -command "cd $x ; read_dir_l ; refresh_left" } ########################################### #Frame and entry areas for directory names frame .top2 entry .top2.e_l -relief groove -bg grey80 -cursor arrow -font {arial 8 {bold}} entry .top2.e_r -relief groove -bg grey80 -cursor arrow -font {arial 8 {bold}} pack .top2.e_l .top2.e_r -side left -fill x -expand true ########################################## #Fake entry (for some reason it should be exists to separate #readings from dif directories entry .fake_l entry .fake_r #pack .fake_l .fake_r -side top -fill x ################################################## #Buttons,entry, text,scrollbar for text on bottom frame .bot -relief groove -bd 2 frame .bot.2 -relief groove -bd 2 pack .bot.2 -fill x entry .bot.2.e_l -bg grey -relief groove -font {arial 8 {bold}} entry .bot.2.e_r -bg grey -relief groove -font {arial 8 {bold}} pack .bot.2.e_l .bot.2.e_r -side left -fill x -expand true text .bot.t -wrap none -height 10 -bg bisque -fg blue -font {monaco 12 {}} -cursor arrow -yscrollcommand [list .bot.scr set] scrollbar .bot.scr -orient vertical -command [list .bot.t yview] history::for entry .bot.comm -font {monaco 12} -bd 1 -bg bisque -cursor arrow -textvariable command_var pack .bot.scr -side right -fill y pack .bot.t .bot.comm -side top -fill x -expand true bind .bot.comm <Return> {+ ; .bot.t delete 1.0 end ; .bot.t insert end [exec_cmd [.bot.comm get]]; .bot.comm delete 0 end ; after 100 focus .bot.comm } bind .bot.comm <Enter> {focus .bot.comm} foreach bot {.b1 .b2 .b3 .b4 .b5 .b6 .b7 .b8 .b9 .b10} { button .bot$bot -relief groove pack .bot$bot -side left -fill x -expand true } .bot.b1 config -text "Help F1" -command About .bot.b2 config -text "Menu F2" -command {} .bot.b3 config -text "View F3" -command {} .bot.b4 config -text "Editor F4" -command {editor} .bot.b5 config -text "Copy F5" -command "" .bot.b6 config -text "RenMv F6" -command "" .bot.b7 config -text "MkDir F7" -command "" .bot.b8 config -text "Delete F8" -command "" .bot.b9 config -text "Run Tcl Code F9" -command {focus .bot.t ; run_tcl .bot.t} .bot.b10 config -text "Exit F10" -command exit pack .bot -side bottom -fill both -expand true ######################### ############################# #Right drive lists frame .top.f_r -relief groove -bd 2 pack .top.f_r -fill x -expand true -fill x -side left foreach x [file volume] { button .top.f_r.f$x -text [file native $x] -font {arial 8 {bold} } -relief groove -command "" pack .top.f_r.f$x -side left .top.f_r.f$x config -command "cd $x ; read_dir_r ; refresh_right" } pack .top -side top -fill x -expand true pack .top2 -side top -fill x -expand true ############################## ################################# #Left listboxes listbox .l -bg bisque -width 20 -export no -bd 0 -relief raised -selectmode browse -yscrollcom LBscroll -font {monaco 10} listbox .sz -bg bisque -width 8 -export no -bd 0 -selectmode browse -yscrollcom LBscroll -font {monaco 10} listbox .time -bg bisque -export no -width 15 -bd 0 -selectmode browse -yscrollcom LBscroll -font {monaco 10} pack .l .sz .time -side left -fill both -expand true ############################ #Right side listboxes listbox .l_r -bg bisque -width 20 -export no -bd 0 -relief raised -selectmode browse -yscrollcom LBscroll_r -font {monaco 10} listbox .sz_r -bg bisque -width 8 -export no -bd 0 -selectmode browse -yscrollcom LBscroll_r -font {monaco 10} listbox .time_r -bg bisque -export no -width 15 -bd 0 -selectmode browse -yscrollcom LBscroll_r -font {monaco 10} pack .l_r .sz_r .time_r -side left -fill both -expand true ################### #Fill all listboxes proc read_dir_l {} { #clean all listboxes .l delete 0 end .sz delete 0 end .time delete 0 end .l insert end ".." .sz insert end ".." .time insert end ".." ### set dir [glob -nocomplain ./*] set files [glob -nocomplain ./*] set dirs {} set others {} set dsize {} set dtime {} set fsize {} set ftime {} foreach f [lsort -dictionary $files] { if { ![file isdirectory $f] && ![file isfile $f] } { lappend others [file tail $f] lappend fsize "NOT A FILE" lappend ftime "------" } elseif [file isdirectory $f] { lappend dirs [file tail $f] lappend dsize "DIR" lappend dtime [clock format [file mtime $f] -format {%b-%d-%y %H:%M}] } else { lappend others [file tail $f] lappend fsize [file size $f] lappend ftime [clock format [file mtime $f] -format {%b-%d-%y %H:%M}] } } foreach f [concat $dirs $others] { .l insert end $f } foreach z [concat $dsize $fsize] { .sz insert end $z } foreach t [concat $dtime $ftime] { .time insert end $t } .top2.e_l delete 0 end .top2.e_l insert end [file native [pwd]] .fake_l delete 0 end .fake_l insert end [pwd] } ########################## #Fill right listboxes proc read_dir_r {} { #clean all listboxes .l_r delete 0 end .sz_r delete 0 end .time_r delete 0 end .l_r insert end ".." .sz_r insert end ".." .time_r insert end ".." ### set dir_r [glob -nocomplain ./*] set files_r [glob -nocomplain ./*] set dirs_r {} set others_r {} set dsize_r {} set dtime_r {} set fsize_r {} set ftime_r {} foreach f [lsort -dictionary $files_r] { if { ![file isdirectory $f] && ![file isfile $f] } { lappend others_r [file tail $f] lappend fsize_r "NOT A FILE" lappend ftime_r "------" } elseif [file isdirectory $f] { lappend dirs_r [file tail $f] lappend dsize_r "DIR" lappend dtime_r [clock format [file mtime $f] -format {%b-%d-%y %H:%M}] } else { lappend others_r [file tail $f] lappend fsize_r [file size $f] lappend ftime_r [clock format [file mtime $f] -format {%b-%d-%y %H:%M}] } } foreach f [concat $dirs_r $others_r] { .l_r insert end $f } foreach z [concat $dsize_r $fsize_r] { .sz_r insert end $z } foreach t [concat $dtime_r $ftime_r] { .time_r insert end $t } .top2.e_r delete 0 end .top2.e_r insert end [file native [pwd]] .fake_r delete 0 end .fake_r insert end [pwd] } ################################## read_dir_l read_dir_r ################################# ################################ #Left scroolbar and procs to scroll scrollbar .sy -orient v -command "LBset yview" pack .sy -fill y -after .time -side left proc LBset args { foreach lb {.l .sz .time} { eval $lb $args } } proc LBscroll args { eval .sy set $args LBset yview moveto [lindex $args 0] } foreach lb {.l .sz .time} { bind $lb <ButtonPress-1> { LBset select clear 0 end LBset select set [%W nearest %y] set show [.l curselection] .bot.2.e_l delete 0 end .bot.2.e_l insert end [.l get $show ] } bind $lb <B1-Motion> { LBset select clear 0 end LBset select set [%W nearest %y] LBset see [%W nearest %y] set show [.l curselection] .bot.2.e_l delete 0 end .bot.2.e_l insert end [.l get $show ] } bind $lb <ButtonRelease-1> { LBset select clear 0 end LBset select set [%W nearest %y] set show [.l curselection] .bot.2.e_l delete 0 end .bot.2.e_l insert end [.l get $show ] } } ################################################ #Right scroolbar and proc for scroll scrollbar .sy_r -orient v -command "LBset_r yview" pack .sy_r -fill y -after .time_r -side right proc LBset_r args { foreach lb_r {.l_r .sz_r .time_r} { eval $lb_r $args } } proc LBscroll_r args { eval .sy_r set $args LBset_r yview moveto [lindex $args 0] } foreach lb_r {.l_r .sz_r .time_r} { bind $lb_r <ButtonPress-1> { LBset_r select clear 0 end LBset_r select set [%W nearest %y] set show [.l_r curselection] .bot.2.e_r delete 0 end .bot.2.e_r insert end [.l_r get $show ] } bind $lb_r <B1-Motion> { LBset_r select clear 0 end LBset_r select set [%W nearest %y] LBset_r see [%W nearest %y] set show [.l_r curselection] .bot.2.e_r delete 0 end .bot.2.e_r insert end [.l_r get $show ] } bind $lb_r <ButtonRelease-1> { LBset_r select clear 0 end LBset_r select set [%W nearest %y] set show [.l_r curselection] .bot.2.e_r delete 0 end .bot.2.e_r insert end [.l_r get $show ] } } ####################################################### #Proc to show file names on bottom entry right and left #Scroll selected lines in all listboxes in left proc showItemDown {w w2} { set item [$w curselection] set item2 [expr $item+1] $w2 delete 0 end; $w2 insert end [$w get $item2] foreach sel {.l .sz .time} { $sel selection clear $item $sel selection set $item2 ; $sel selection clear $item } } proc showItemUp {w w2} { set item [$w curselection] set item2 [expr $item-1] $w2 delete 0 end; $w2 insert end [$w get $item2] foreach sel {.l .sz .time} { $sel selection clear $item $sel selection set $item2 ; $sel selection clear $item } } ##################### #Proc to scroll all selection in right side proc showItemDown_r {w w2} { set item [$w curselection] set item2 [expr $item+1] $w2 delete 0 end; $w2 insert end [$w get $item2] foreach sel {.l_r .sz_r .time_r} { $sel selection clear $item $sel selection set $item2 ; $sel selection clear $item } } proc showItemUp_r {w w2} { set item [$w curselection] set item2 [expr $item-1] $w2 delete 0 end; $w2 insert end [$w get $item2] foreach sel {.l_r .sz_r .time_r} { $sel selection clear $item $sel selection set $item2 ; $sel selection clear $item } } proc edit_file {w} { global fileex set fileex [$w get active] if [file isdirectory $fileex] { tk_messageBox -parent . -title "Error" -type ok -icon error -message "This is directory" } else { editor set openfile [open $fileex "r"] .ed.text.t delete 1.0 end .ed.text.t insert end [read $openfile] close $openfile } } ################## #Proc to change left directory list proc read_left {} { #focus .l global fileex set old_dir [.fake_l get] cd $old_dir set dir [.l get active] if [file isdirectory $dir] { cd $dir ; read_dir_l .l selection set 0; .sz selection set 0; .time selection set 0 .l activate 0 .top2.e_l delete 0 end .top2.e_l insert end [file native [pwd]] } else { set fileex [.l get active] if [file executable $fileex] { catch {exec $fileex &} result #.bot.t insert end [eval exec command /c $fileex] } if {[id_giffile] == 1} { img_view $fileex } if {[id_txtfile] == 1} { set openfile [open $fileex "r"] .bot.t delete 1.0 end .bot.t insert end [read $openfile] close $openfile } if {[id_tclfile] == 1} { set dir [pwd] showTcl $dir/$fileex } if {[id_htmlfile] == 1} { set dir [pwd] showHtml $dir/$fileex } } } proc read_right {} { # Get selected list item global fileex focus .l_r set old_dir [.fake_r get] cd $old_dir set dir_r [.l_r get active] if [file isdirectory $dir_r] { cd $dir_r ; read_dir_r .l_r selection set 0; .sz_r selection set 0; .time_r selection set 0 .top2.e_r delete 0 end .top2.e_r insert end [file native [pwd]] } else { set fileex [.l_r get active] if [file executable $fileex] { catch {exec $fileex &} result #.bot.t insert end [eval exec command /c $fileex] } if {[id_giffile] == 1} { img_view $fileex } if {[id_txtfile] == 1} { set openfile [open $fileex "r"] .bot.t delete 1.0 end .bot.t insert end [read $openfile] close $openfile } if {[id_tclfile] == 1} { set dir [pwd] showTcl $dir/$fileex } if {[id_htmlfile] == 1} { set dir [pwd] showHtml $dir/$fileex } } } proc copy_file_to_r {} { set file_l [.l get active] set left_dir [.fake_l get] set right_dir [.fake_r get] set choise [tk_messageBox -parent . -type yesno -default yes -message "Copyn [file native $left_dir/$file_l]nton [file native $right_dir]" -icon question] if {$choise == "yes"} { if [file isdirectory $file_l] { file copy -force $left_dir/$file_l $right_dir refresh_right ; refresh_left cd [.fake_l get] } else { file copy $left_dir/$file_l $right_dir after 100 refresh_left; refresh_right cd [.fake_l get] } } } proc copy_file_to_l {} { set file_r [.l_r get active] set left_dir [.fake_l get] set right_dir [.fake_r get] set choise [tk_messageBox -parent . -type yesno -default yes -message "Copyn [file native $right_dir/$file_r] nton [file native $left_dir]" -icon question] if {$choise == "yes"} { if [file isdirectory $file_r] { file copy $right_dir/$file_r $left_dir; refresh_left ; refresh_right cd [.fake_r get] } else { file copy $right_dir/$file_r $left_dir refresh_left cd [.fake_r get] } } } #################### #Rename move files and Directories proc ren_move {w} { catch [destroy .move] toplevel .move wm resizable .move 0 0 wm title .move "Rename" grab .move center_win .move global file_move set file_move [$w get active] label .move.l -text "Current name is: n$file_move nn Enter new name: " -relief groove -font {arial 8 {bold}} entry .move.e -font {arial 8 {bold}} .move.e insert end $file_move focus .move.e frame .move.ok -relief sunken -bd 2 button .move.ok.ok -text " Ok " -padx 10 -pady 5 -command {file rename $file_move [.move.e get]; after 1 "refresh_right; refresh_left; destroy .move"} button .move.cancel -text Cancel -command "destroy .move" pack .move.l .move.e -side top -fill x -expand true pack .move.ok .move.ok.ok .move.cancel -side left -padx 10 -pady 5 bind .move.e <Return> {file rename $file_move [.move.e get]; after 30 refresh_right; refresh_left; after 35 destroy .move } } ############## proc delete_file_l {} { set file_l [.l get active] set left_dir [.fake_l get] if [file isdirectory $file_l] { set cur [.l curselection] set question [tk_messageBox -type okcancel -default cancel -message " Delete directory and files in n [file native $left_dir/$file_l]" -icon question] switch -- $question { ok { file delete -force $file_l ; refresh_left ; refresh_right} } } else { set cur [.l curselection] set question [tk_messageBox -type okcancel -default cancel -message " Delete files n [file native $left_dir/$file_l]" -icon question] switch -- $question { ok { file delete $left_dir/$file_l; refresh_left; refresh_right} } #.l selection set $curent #.l see $curent } } proc delete_file_r {} { set file_r [.l_r get active] set right_dir [.fake_r get] if [file isdirectory $file_r] { set curent [.l_r curselection] set question [tk_messageBox -type okcancel -default cancel -message " Delete directory and files in n [file native $right_dir/$file_r] " -icon question] switch -- $question { ok { file delete -force $file_r ; refresh_left ; refresh_right } } } else { set curent [.l_r curselection] set question [tk_messageBox -type okcancel -default cancel -message " Delete files n [file native $right_dir/$file_r]" -icon question] switch -- $question { ok { file delete $right_dir/$file_r; refresh_right; refresh_left } } } } proc mk_dir {w} { catch [destroy .mkdir] toplevel .mkdir wm resizable .mkdir 0 0 wm title .mkdir "Create new Directory" grab .mkdir center_win .mkdir label .mkdir.l -text " Current directory is: n[file native [pwd]] nn Enter new directory name " -relief groove -font {arial 8 {bold}} entry .mkdir.e -font {arial 8 {bold}} focus .mkdir.e frame .mkdir.ok -relief sunken -bd 2 button .mkdir.ok.ok -text " Ok " -padx 10 -pady 5 -command {file mkdir [.mkdir.e get]; after 1 "refresh_right; refresh_left; destroy .mkdir"} button .mkdir.cancel -text Cancel -command "destroy .mkdir" pack .mkdir.l .mkdir.e -side top -fill x -expand true pack .mkdir.ok .mkdir.ok.ok .mkdir.cancel -side left -padx 10 -pady 5 bind .mkdir.e <Return> {file mkdir [.mkdir.e get]; after 30 refresh_right; refresh_left; after 35 destroy .mkdir } } #end mk_dir proc find_win {w} { catch [destroy .find] toplevel .find center_win .find wm title .find "Find" wm resizable .find 0 0 grab .find label .find.l -text "tCurrent directory is:tnt[file native [pwd]]ttnnSearch Filename:" -relief groove -font {arial 10 {bold}} entry .find.e pack .find.l .find.e -fill x focus .find.e frame .find.ok -relief sunken -bd 1 button .find.ok.ok -padx 10 -pady 5 -text Find -command {.bot.t delete 1.0 end ; find_file [pwd] [.find.e get] ; destroy .find} button .find.cancel -text Cancel -command "destroy .find" pack .find.ok .find.ok.ok .find.cancel -side left -padx 10 -pady 5 } ######################## #Proc find file proc find_file { startDir namePat} { #set namePat [.find.e get] set pwd [pwd] if [catch {cd $startDir} err] { puts stderr $err return } foreach match [glob -nocomplain -- $namePat] { .bot.t insert end "[file native $startDir/$match]n" if {$namePat != $match } { #.bot.t insert end "$startDir$matchn" #.bot.t insert end "no match" } else { #.bot.t insert end "no files found" } } foreach file [glob -nocomplain *] { if [file isdirectory $file] { find_file $startDir/$file $namePat update } } cd $pwd } #################################################### #Refresh left listbox after copy or deleting a file proc refresh_left {} { set left_dir [.fake_l get] set cur [.l curselection] if {$cur == "" } { focus .l after 3 ".l selection set 0 ; .sz selection set 0 ; .time selection set 0" .l see 0 .l activate 0 } else { cd $left_dir ; read_dir_l .l selection set $cur ; .sz selection set $cur ; .time selection set $cur .l see $cur .l activate $cur .top2.e_l delete 0 end .bot.2.e_l delete 0 end .top2.e_l insert end [file native [pwd]] } } refresh_left proc refresh_right {} { set right_dir [.fake_r get] set cur [.l_r curselection] if {$cur == ""} { .l_r selection set 0 ; .sz_r selection set 0; .time_r selection set 0 .l_r see 0 .l_r activate 0 } else { cd $right_dir ; read_dir_r .l_r selection set $cur; .sz_r selection set $cur; .time_r selection set $cur .l_r see $cur .l_r activate $cur .top2.e_r delete 0 end .bot.2.e_r delete 0 end .top2.e_r insert end [file native [pwd]] } } proc viewFile {w} { #global fileex set fileex [$w get active] if [file isdirectory $fileex] { tk_messageBox -parent . -title "Error" -type ok -icon error -message "This is directory" } else { set openfile [open $fileex "r"] .bot.t delete 1.0 end .bot.t insert end [read $openfile] close $openfile } } refresh_right ######################### ######################## #Bindings global #bind .bot.t <Enter> "focus .bot.t" bind . <F4> "editor" bind . <F9> {focus .bot.t ; run_tcl .bot.t} ######################### #Bindings keys for left side foreach bind_left { .l .sz .time} { bind $bind_left <Enter> {focus .l ; set old_dir [.fake_l get] ; cd $old_dir ; .bot.b2 config -command {}; .bot.b3 config -command {viewFile .l} ; .bot.b5 config -command copy_file_to_r ; .bot.b6 config -command {ren_move .l} ; .bot.b7 config -command {mk_dir .l} ; .bot.b8 config -command delete_file_l} } bind .l <Double-Button-1> "read_left;" bind .l <Return> {read_left} bind .l <Down> {showItemDown .l .bot.2.e_l} bind .l <Up> {showItemUp .l .bot.2.e_l} bind .l <KeyPress-r> "focus .l_r" bind .l <F3> {viewFile .l} bind .l <F5> copy_file_to_r bind .l <F6> {ren_move .l} bind .l <F7> {mk_dir .l} bind .l <F8> delete_file_l ############################################# #Bindings keys for right side bind .l_r <Double-Button-1> "read_right" bind .l_r <Return> {read_right} foreach bind_right {.l_r .sz_r .time_r} { bind $bind_right <Enter> {focus .l_r; set old_dir [.fake_r get] ; cd $old_dir ; .bot.b3 config -command {viewFile .l_r}; .bot.b8 config -command delete_file_r; .bot.b5 config -command copy_file_to_l ; .bot.b6 config -command {ren_move .l_r} ; .bot.b7 config -command {mk_dir .l_r}} } bind .l_r <KeyPress-r> "focus .l" bind .l_r <F3> {viewFile .l_r} bind .l_r <F5> copy_file_to_l bind .l_r <F6> {ren_move .l_r} bind .l_r <F7> {mk_dir .l_r} bind .l_r <F8> delete_file_r bind .l_r <Down> {showItemDown_r .l_r .bot.2.e_r} bind .l_r <Up> {showItemUp_r .l_r .bot.2.e_r} #################################### #Txt, ASCII and bat files viewer proc id_allfiles {} { global fileex set ext_txt [file extension $fileex] switch $ext_txt { .doc {return 1} .txt {return 1} .jpeg {return 1} .jpg {return 1} .txt {return 1} .htm {return 1} .html {return 1} } return 0 } proc id_txtfile {} { global fileex set ext_txt [file extension $fileex] switch $ext_txt { .txt {return 1} .TXT {return 1} .bat {return 1} .BAT {return 1} .c {return 1} .C {return 1} .h {return 1} .H {return 1} } return 0 } proc id_tclfile {} { global fileex set ext_tcl [file extension $fileex] switch $ext_tcl { .tcl {return 1} .TCL {return 1} .tk {return 1} .TK {return 1} } return 0 } ####################################### proc id_giffile {} { global fileex set ext_gif [file extension $fileex] switch $ext_gif { .gif {return 1} .GIF {return 1} .jpeg {return 1} .jpg {return 1} .JPEG {return 1} .JPG {return 1} .tif {return 1} } return 0 } proc id_htmlfile {} { global fileex set ext_html [file extension $fileex] switch $ext_html { .htm {return 1} .html {return 1} .HTM {return 1} .HTML {return 1} } return 0 } ############################# #Proc file atributes and properties proc fileprop pathname { set padx 6 if {$pathname=="."} {set pathname [pwd]} set pathname [file join [pwd] $pathname] set checkbuttons [list] file stat $pathname a ;# may error out if no such file set w .[clock clicks] set ::$w(dir) [file dir $pathname] set ::$w(file) [file tail $pathname] toplevel $w grab $w wm title $w [file nativename $pathname] wm resizable $w 0 0 wm geometry $w +300+150 set size [file size $pathname] if {$size < 0} { set size [format "%2.2f GB" [expr ($size/-1024.0)/-1024.0/-1024.0*10.0]] } else { if {$size > 1073741824.0} { set size [format "%2.2f GB" [expr ($size/1024.0)/1024.0/1024.0]] } else { if { $size > 1048576.0 } { set size [format "%2.2f MB" [expr ($size/1024.0) /1024.0 ]] } else { if {$size > 1024} { set size [ format "%2.2f KB" [expr $size / 1024.0 ]] } } } } set textual [list Name [file tail $pathname] Directory [file nativename [file dir $pathname]] Type [file type $pathname] Size $size Created [date,time $a(ctime)] "Last modified" [date,time $a(mtime)] "Last accessed" [date,time $a(atime)] ] foreach {name value} [file attr $pathname] { if [regexp {^[01]$} $value] { lappend checkbuttons $name $value } else { lappend textual $name [file nativename $value] } } set n 0 foreach {name value} $textual { grid [label $w.${n}n -text $name:] [label $w.${n}v -text $value] -sticky w -padx $padx incr n } grid [hr $w.$n] -sticky we -columnspan 2 -padx $padx -pady 6 set n0 [incr n] foreach {name value} $checkbuttons { incr n set ::$w($name) $value grid [checkbutton $w.$n -text $name -var $w($name) -borderwidth 0] -sticky w -col 1 -padx $padx } grid [label $w.att -text Attributes:] -row $n0 -sticky w -padx $padx grid [hbuttons $w.b [list OK "fileprop:apply $w; destroy $w; unset $w" Cancel "destroy $w; unset $w" Apply "fileprop:apply $w" ]] -col 1 -padx $padx wm protocol $w WM_DELETE_WINDOW "destroy $w; unset $w" focus $w } proc fileprop:apply {w} { upvar #0 $w a set cmd [list file attributes [file join $a(dir) $a(file)]] foreach {name value} [array get a] { if [regexp {^-} $name] {lappend cmd $name $value} } eval $cmd } proc hbuttons {w tc} { frame $w set n 1 foreach {t c} $tc { button $w.$n -text $t -command $c -width 8 incr n } eval pack [winfo children $w] -side left -padx 3 -pady 6 -fill x -anchor e return $w } proc hr {w} {frame $w -height 2 -borderwidth 1 -relief sunken} proc date,time {{when {}}} { if {$when == ""} {set when [clock seconds]} return [clock format $when -format "%Y-%m-%d,%H:%M:%S"] } ####################### #Proc popup menus proc pop_upmen_l {w} { global act set act [$w curselection] menu .popup_l -tearoff 0 .popup_l add separator .popup_l add command -label Info -command {fileprop [.bot.2.e_l get]} .popup_l add separator .popup_l add command -label View -command "viewFile .l" .popup_l add command -label Edit -command "edit_file .l" .popup_l add separator .popup_l add command -label Find -command {find_win .l} .popup_l add command -label Copy -command copy_file_to_r .popup_l add command -label NewDir -command "mk_dir .l" .popup_l add separator .popup_l add command -label Rename -command "ren_move .l" .popup_l add command -label Delete -command delete_file_l .popup_l add separator bind $w <ButtonPress-3> {tk_popup .popup_l %X %Y } } proc pop_upmen_r {w} { global act set act [$w curselection] menu .popup_r -tearoff 0 .popup_r add separator .popup_r add command -label Info -command {fileprop [.bot.2.e_r get]} .popup_r add separator .popup_r add command -label View -command "viewFile .l_r" .popup_r add command -label Edit -command "edit_file .l_r" .popup_r add separator .popup_r add command -label Find -command {find_win .r} .popup_r add command -label Copy -command copy_file_to_l .popup_r add command -label NewDir -command "mk_dir .l_r" .popup_r add separator .popup_r add command -label Rename -command "ren_move .l_r" .popup_r add command -label Delete -command delete_file_r .popup_r add separator bind $w <ButtonPress-3> {tk_popup .popup_r %X %Y } } pop_upmen_l .l pop_upmen_r .l_r ##################### #Image viewer procs #Var set set i 1 set im 1 ###################### #image viewer procedure proc img_view {fileex} { global i global im incr i incr im toplevel .img$i wm title .img$i $fileex #wm minsize .img$i 800 640 image create photo $im $im read $fileex set im_y [image height $im] set im_x [image width $im] wm minsize .img$i 200 100 canvas .img$i.c -relief groove -bd 2 -scrollregion {0 0 3000 3000} -yscrollcommand [list .img$i.scr set] -xscrollcommand [list .img$i.xscr set] scrollbar .img$i.scr -orient vertical -command [list .img$i.c yview] scrollbar .img$i.xscr -orient horizontal -command [list .img$i.c xview] .img$i.c create image 5 5 -image $im -anchor nw update pack .img$i.scr -side right -fill y pack .img$i.xscr -side bottom -fill x pack .img$i.c -side left -fill both -expand true } ###################################### #Procedure to run command from entry proc exec_cmd {command} { global tcl_platform set result " " set check_cmd [lindex $command 0] set cmd [info commands $check_cmd] if {[string length $cmd ] > 0} { .bot.t insert end [set result [eval $command]] refresh_left #refresh_right } else { if {$tcl_platform(platform) == "windows"} { eval exec command /c [.bot.comm get] } else { eval exec [.bot.comm get] } } } ############################# #Procedure for running tcl from text widgets proc run_tcl {w} { if {[interp exists eval_env]} { interp delete eval_env run_tcl $w } else { interp create eval_env load {} Tk eval_env set all [$w get 1.0 end] eval_env eval $all } } ########################## ############################################ #Registry procedure #Evaluate file extensions and execute applcation ::tcl::OptProc perSub { {string -string "" "String to work on"} {pattern -string "" "What to substitute for, e.g., %v"} {subst -string "" "What to put in for $pattern"} {args -list {} "More pattern/subst pairs"} } { # Add the required instances to the optional list set args [linsert $args 0 $pattern $subst] # Process the list foreach {pattern subst} $args { # Validate pattern if { ! [string match %* $pattern]} { error "Bad pattern <<$pattern>>: Should be %something" } # Escape dangerous characters ('' and '&') in substitution string regsub -all {\|&} $subst {\0} subst # Do substitutions on string regsub -all $pattern $string $subst string } # foreach return $string } proc showHtml {htmlFile} { global tcl_platform if {$tcl_platform(platform) == "windows"} { set root HKEY_CLASSES_ROOT set appKey [registry get $root\.html ""] set appCmd [registry get $root\$appKey\shell\open\command ""] set appCmd [perSub $appCmd %1 $htmlFile] regsub -all {\} $appCmd {\\} appCmd eval exec $appCmd & } else { } } proc showTcl {tclFile} { global tcl_platform if {$tcl_platform(platform) == "windows"} { set root HKEY_CLASSES_ROOT set appKey [registry get $root\.tcl ""] set appCmd [registry get $root\$appKey\shell\open\command ""] set appCmd [perSub $appCmd %1 $tclFile] regsub -all {\} $appCmd {\\} appCmd eval exec $appCmd & } else { } } ########################################## proc editor {} { catch [destroy .ed] toplevel .ed wm resizable .ed 0 0 wm title .ed "TclMC Editor" menu .ed.menubar -relief raised -borderwidth 1 menu .ed.menubar.file -tearoff 0 .ed.menubar add cascade -label "File" -menu .ed.menubar.file -underline 0 .ed.menubar.file add separator .ed.menubar.file add command -label "New" -command {clear_all .ed.text.t} .ed.menubar.file add separator .ed.menubar.file add command -label "Open" -command {clear_all .ed.text.t ; textOpen} .ed.menubar.file add separator .ed.menubar.file add command -label "Close" -command {clear_all .ed.text.t} .ed.menubar.file add separator .ed.menubar.file add command -label "Save as..." -command {textSaveAs} .ed.menubar.file add separator .ed.menubar.file add command -label "Print" -command {printFormat} .ed.menubar.file add separator .ed.menubar.file add command -label "Exit" -command {bell ; prompt_close .} ###################### .ed.menubar add cascade -label "Edit" -menu .ed.menubar.editt -underline 0 menu .ed.menubar.editt -tearoff 0 .ed.menubar.editt add separator .ed.menubar.editt add command -label "Select All" -command {.ed.text.t tag add sel 1.0 end} .ed.menubar.editt add separator .ed.menubar.editt add command -label "Copy" -command {tk_textCopy .ed.text.t} .ed.menubar.editt add separator .ed.menubar.editt add command -label "Paste" -command "tk_textPaste .ed.text.t" .ed.menubar.editt add separator .ed.menubar.editt add command -label "Cut" -command "tk_textCut .ed.text.t" .ed.menubar.editt add separator .ed.menubar.editt add command -label "Clear" -command "clear_all .ed.text.t" .ed.menubar.editt add separator #################################### .ed.menubar add cascade -label "Test Tcl" -menu .ed.menubar.run -underline 0 menu .ed.menubar.run -tearoff 0 .ed.menubar.run add separator .ed.menubar.run add command -label "Run Tcl" -command {run_tcl .ed.text.t} .ed.menubar.run add separator ############################ .ed.menubar add cascade -label "Font Size" -menu .ed.menubar.font -underline 0 menu .ed.menubar.font -tearoff 0 .ed.menubar.font add separator .ed.menubar.font add command -label "Small" -command ".ed.text.t config -font {Monaco 8 {}}" .ed.menubar.font add separator .ed.menubar.font add command -label "Medium" -command ".ed.text.t config -font {Monaco 9 {}}" .ed.menubar.font add separator .ed.menubar.font add command -label "Large" -command ".ed.text.t config -font {Monaco 12 {}}" ############################# .ed.menubar add cascade -label "Help" -menu .ed.menubar.help -underline 0 menu .ed.menubar.help -tearoff 0 .ed.menubar.help add separator .ed.menubar.help add command -label "Help" -command {About} .ed.menubar.help add separator .ed.menubar.help add command -label "About" -command {About} .ed conf -menu .ed.menubar proc clear_all { widgetname } { $widgetname delete 1.0 end } ##################################### proc textOpen { { fn ""} } { global .ed.text.t set types { {{All Files} *} {{Text Files} {.txt}} } if { [string match {} $fn] && ([catch {tk_getOpenFile -filetypes $types -title "Source File" -parent .ed} fn] || [string match {} $fn]) } { return } set fp [open $fn] while {![eof $fp]} { .ed.text.t insert end [read $fp] } close $fp } ##################################### # Handles window manager Close choice. proc prompt_close { widgetname } { # If main window, prompt. if { $widgetname == "." } { set result [tk_messageBox -parent .ed -title {Exit?} -type yesno -icon warning -message "Do you really want to quit?"] if { $result == "yes" } { destroy .ed } } else { # Not the main window, destroy it. destroy $widgetname } } wm protocol . WM_DELETE_WINDOW "prompt_close .ed" #################################### #save as command proc textSaveAs {} { global .ed.text.t set types { {{Tcl Files} {.tcl}} {{Text Files} {.txt}} {{All Files} *} } set filename [tk_getSaveFile -title "Save as..." -filetypes $types] if {$filename !=""} { set file_open [open $filename w] puts -nonewline $file_open [.ed.text.t get 1.0 end] close $file_open refresh_left refresh_right } } #################################### #Print using ms Write application proc printFormat {} { global tcl_platform if {$tcl_platform(platform) == "unix"} { } if {[file exists c:/windows/write.exe]} { set file [open c:/tmp/out.txt w] puts $file [.ed.text.t get 1.0 end] close $file exec start /m write /p c:/tmp/out.txt & } else { if {[file exists c:/progra~1/accessories/wordpad.exe]} { set file [open c:/tmp/out.txt w] puts $file [.ed.text.t get 1.0 end] close $file exec start /m c:/progra~1/accessories/wordpad.exe /p c:/tmp/out.txt & } else { if {[file exists c:/winnt/system32/write.exe]} { set file [open c:/tmp/out.txt w] puts $file [.ed.text.t get 1.0 end] close $file exec c:/winnt/system32/write.exe /p c:/tmp/out.txt & } else { ## catch [destroy .formated] toplevel .formated wm title .formated "" wm resizable .formated 0 0 label .formated.l -text "You need install MS Windows n WordPad application!n Press Ok button to continue" -relief groove button .formated.b -text Ok -command "destroy .formated" pack .formated.l -side top pack .formated.b -side bottom } } } } ############################### #Image Buttons set imnew { R0lGODlhEAAQAPcAAAAAAMbGxv////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQABAA AAhJAAMIHEiwIEEACBMiNCgQwL+HEBcadAjxoUMAEytaTFiQokaLHT9GDCnyH8aDJU2SFHlyoMeP LRumjBngpUaaCnNKZMizJ8+AAAA7 } #End New ################ #Open button image set imopen { R0lGODlhEAAPAPcAAAAAAMbGxv//AP////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQAA8A AAhMAAMIHEiwoMGDCBMSBMBQoUAAAv4JYEix4UKJAiJq/AegIESJIDV2vCiyoskAHydmXMmyIwCJ EFm2fKhS5sqRKGPanLjQ5EmHQIMGBAA7 } #End open image ####################################### #Save Image set imsave { R0lGODlhEAAQAPcAAAAAAAAAnAAA/8bGxs7Ozv////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAMALAAAAAAQABAA AAhhAAcIHEiwoMGDBgEEECAAgMOHAgIAGKiQIYGLAQIQiDhRYEUBFwlk3CiR4sKGDx1yNMmwpcuG JlPKdBjzn82b/x7WxGlTp0eJPHvS/AkgaM6hAxQWDeozqUOjTWdKRUg1IAA7 } #End Save Image ######################### #image Select all set imselectall { R0lGODdhFAARAPcAAAAAALa2qtu2qrbbqtvbqrOzs7a2/9u2/7bb/9vb/////wBMWTQJAAAAAAAA AAAAAKgF9xcAABwANAkFAAAApG0/A1r4AgBk6wIACAAjAacrAAABAMk7AAAFAOA/AAAAAAAAAAAA AEAGAAAAAAAA9wPWFE4ifwMJAAAA1hRa+AIAkOwCAAAyVwQBAA5gAAAAAAAAVuvHMaj4twVQUiAD WAJABgEQAAAAAEAGAAAAAAAAAAAAABMBCeAABDAA1hQfBR8DWAUfAwAAAAACAOrrAgAIAB8BpysA AAEANQIBAQYAAQAAANYUZAAAAAIANQIAAC8AFAAaAFYAJwBlAAAAAAAAQPdeAAC3BSHsAAAAAAAA AADHMQAAAADc68cxqPi3BUIAnhcEAMjsxzEGAAEAJQAfAHoCSezg60nsTiOvBwgD3xOPEwwFSO0a AC8A///3/wAACAPfE8cDAAD//wAAHwAgAPLrCiavBxjsxzF6At8TUezHMeDsJwHXExjsxzGLax8B jxPg7EsB1xPc7McxSO3HMRjsxzEBAACAQXBwRXZlbnRzXFNjaGVtZXNcQXBwc1wuRGVmYXVsdFxN QUdJQ01lbnVDb21tYW5kXC5DdXJyZW50AAngAACDAP4ABgG3BbDsS3tXBKj4twVwLtcFIQDwAAEA BgAfAEMBAAAAACYAHwAAANYUBQDEFvcXWvisAx8DhAxDAR8AJgAlACcAHwAmACUAJwAAAK41AADE Na41jwcfAgAAAADHAP1VrjUCAAAAAgCvNQDzrjUGGwcL4uzAHZUG9xf7Bq41AABI7boAAAA27TgC SO3HMfTsxzEbA98TAACuNU1BR0lDTWVudUNvbW1hbmQAAwAAQO0tJG8YAAD+////BRAczyRFAgDH MSRFAgDC7gIAiwAAANYUDQBO9wAAACAFANztnQOTAAEQSO3HMQwF9xcAAAD///8FEBzPFAIkRQIA VAAM7hQL9zUAAP7///8FEBzPFAIQAhIAAAB+7RkAQwEYABkAPwwvASwAAAAAFAARAAAIiwALCBxI sKDBgwgPAlioQMFChg4XGgQQoKKAigEEXKwIYCLGjRk1ZuxYUMGAAwMMnEyZkkABBQYVJAgwsybN mzALUrRYcQDIACQJAkAgAEEAokaTAp04M6kAA0eLCgg6UAHGq1hzErQasifIAVoH7sz4kSdVgQCa RoVKFOrZAg8bPgQgV2LCu3jzBgQAOw== } #end image Select all ######################## #Copy Image set imcopy { R0lGODlhEAAQAPcAAAAAAM7Ozv////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQABAA AAhSAAEIHEhwYICDAP4pXMjwH4CDARISbOgQokSBFCsidDiQ4sONFxNyLChSoUiMDFGmdNhQpcmX KUuOdMlxoUyPJW+2zJnRJs+eM2m2hBiRZMGAAAA7 } #End Copy Image ############################ #Image Cut set imcut { R0lGODlhEAAQAPcAAAAAAMbGxv////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQABAA AAhEAAMIHCgQAMGDCA0iXBhAocB/DhMOhMiw4MOICw1SrFhwI8eGGAcCGEnSI8GIJBk6VBhS5EiX LSU2/DizJkeWNEEeDAgAOw== } #End Image Cut ####### #Image Paste set impaste { R0lGODlhEAAQAPcAAAAAAAAAY2NjY8bGxv////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////yH5BAEAAAMALAAAAAAQABAA AAhgAAcIHEiwoMEBABICOIhQIQABAhwuFAjgn8WHCSNa/DexIkeIIDVypHhRYsKLJDeqVNlxZYCX MF+m3BjAZYCZFmuqrHnTI81/MIHK9JlzZU6ENmPypOhQp8uDSmMyZBgQADs= } #End Image Past ####################### ######################## #Image Ptint set imprint { R0lGODdhEwATAPcAAAAAAP8AAABtAACSAG1tVZJtVW2SVZKSVW1tqpJtqm2SqpKSqra2qtu2qrbb qtvbqrOzs7a2/7bb/9v//////20/Azb1AgBk6wIACAD/AacrAAABAMk7AADzAuA/AAAAAAAAAAAA AEAGAAAAAAAA9wPWFE4ifwMJAAAA1hQ29QIAkOwCAAAyVwQBAA5gAAAAAAAAVuvHMYT1twVQUiAD WAJABgEQAAAAAEAGAAAAAAAAAAAAABMBCeAABDAA1hQfBR8DWAUfAwAAAAACAOrrAgAIAB8BpysA AAEANQIBAQYAAQAAANYUZAAAAAIANQIAAC8AFAAaAFYAJwBlAAAAAAAAQPdeAAC3BSHsAAAAAAAA AADHMQAAAADc68cxhPW3BUIAnhcEAMjsxzEGAAEAJQAfAHoCSezg60nsTiOvBwgD3xOPEwwFSO0a AC8A///3/wAACAPfE8cDAAD//wAAHwAgAPLrCiavBxjsxzF6At8TUezHMeDsJwHXExjsxzGLax8B jxPg7EsB1xPc7McxSO3HMRjsxzEBAACAQXBwRXZlbnRzXFNjaGVtZXNcQXBwc1wuRGVmYXVsdFxN QUdJQ01lbnVDb21tYW5kXC5DdXJyZW50AAngAACDAP4ABgG3BbDsS3tXBIT1twVwLtcFIQDwAAEA BgAfAEMBAAAAACYAHwAAANYUBQDEFvcXNvWsAx8DRAhDAR8AJgAlACcAHwAmACUAJwAAAK41AADE Na41jwcfAgAAAADHAP1VrjUCAAAAAgCvNQDzrjUGGwcL4uzAHZUG9xf7Bq41AABI7boAAAA27TgC SO3HMfTsxzEbA98TAACuNU1BR0lDTWVudUNvbW1hbmQAAwAAQO0tJG8YAAD+////BRAczyRFAgDH MSRFAgDC7gIAiwAAANYUDQBC9gAAACAFANzt9xcUAiRF9xddJrcHOwCBAFLtxzGEAAIAFAIFACsA GwNTAhQL9zUAAP7///8FEBzPFAKa7Q9Hnwc7AIEAJEUCAPcXgEUCACwAAAAAEwATAAAIjAAhCBxI sKDBgwgLAljIsOHCgwAoSJxIEQBECgspTrRoMCLFCRRAYrzokOHIjhJFauSoEGPJiCwHZpwIsqZL hS9LEly4gIACAgkIHEBQwEACAw8heNTIdKNSCgyiNmDgIOoAAQwCBIhqMWLUr2DBRnDQFWoDCQwi NFCL1kGEtA+65pwrkGFCpUnvJgwIADs= } #End Pint Image ########################### #Image Protocol set improtocol { R0lGODdhEgASAPcAAAAAAG0AAJIAAP8AAG0AVZIAVW1tVZJtVW2SVZKSVW0AqpIAqm1tqpJtqm2S qpKSqra2qtu2qrbbqrOzs7a2/9u2/7bb/9vb/9v//////6crAAABAMk7AADzAuA/AAAAAAAAAAAA AEAGAAAAAAAA9wPWFE4ifwMJAAAA1hQ6+gIAkOwCAAAyVwQBAA5gAAAAAAAAVuvHMYj6twVQUiAD WAJABgEQAAAAAEAGAAAAAAAAAAAAABMBCeAABDAA1hQfBR8DWAUfAwAAAAACAOrrAgAIAB8BpysA AAEANQIBAQYAAQAAANYUZAAAAAIANQIAAC8AFAAaAFYAJwBlAAAAAAAAQPdeAAC3BSHsAAAAAAAA AADHMQAAAADc68cxiPq3BUIAnhcEAMjsxzEGAAEAJQAfAHoCSezg60nsTiOvBwgD3xOPEwwFSO0a AC8A///3/wAACAPfE8cDAAD//wAAHwAgAPLrCiavBxjsxzF6At8TUezHMeDsJwHXExjsxzGLax8B jxPg7EsB1xPc7McxSO3HMRjsxzEBAACAQXBwRXZlbnRzXFNjaGVtZXNcQXBwc1wuRGVmYXVsdFxN QUdJQ01lbnVDb21tYW5kXC5DdXJyZW50AAngAACDAP4ABgG3BbDsS3tXBIj6twVwLtcFIQDwAAEA BgAfAEMBAAAAACYAHwAAANYUBQDEFvcXOvqsAx8DeAtDAR8AJgAlACcAHwAmACUAJwAAAK41AADE Na41jwcfAgAAAADHAP1VrjUCAAAAAgCvNQDzrjUGGwcL4uzAHZUG9xf7Bq41AABI7boAAAA27TgC SO3HMfTsxzEbA98TAACuNU1BR0lDTWVudUNvbW1hbmQAAwAAQO0tJG8YAAD+////BRAczyRFAgDH MSRFAgDC7gIAiwAAANYUDQBO9wAAACAFANztnQOTAAEQSO3HMQwF9xcAAAD///8FEBzPFAIkRQIA VAAM7hQL9zUAAP7///8FEBzPFAIQAhIAAAB+7RkAQwEYABkADwwvASwAAAAAEgASAAAItAAnCBxI sKDBgwMBAEB4EMCChQYVFnQIcaKAigoVVCQIQMAAhQofFICQQWJCAQoGPIDwwMACBxkwZIBgsmNK BywVMsjAM0MAAQI7LlBJcyXPCxAuLAA6oSOBAQcYJICA4AACqkMhOh1wFQIECV55mmyKkqtXChQg UBDLEaUAnF4thC3ZVsEBChEsRJCwl23CBSR7Zqjw4IDXjQICOEiwmMEBBw0cRN3YNMBPAZgx/wzA sPPAgAA7 } #Emd Img Protocol ########################### #Image Chart Loader set imchart { R0lGODdhFQATAPcAAAAAAG1tVZKSVW1tqpKSqra2qrbbqtvbqrOzs8zMzLa2/9vb/////xdkPrcH AACmAsABAgAFAIQKAgAFAAAApG0/Azr6AgBk6wIACAACAacrAAABAMk7AAAG6+A/AAAAAAAAAAAA AEAGAAAAAAAA9wPWFE4ifwMJAAAA1hQ6+gIAkOwCAAAyVwQBAA5gAAAAAAAAVuvHMYj6twVQUiAD WAJABgEQAAAAAEAGAAAAAAAAAAAAABMBCeAABDAA1hQfBR8DWAUfAwAAAAACAOrrAgAIAB8BpysA AAEANQIBAQYAAQAAANYUZAAAAAIANQIAAC8AFAAaAFYAJwBlAAAAAAAAQPdeAAC3BSHsAAAAAAAA AADHMQAAAADc68cxiPq3BUIAnhcEAMjsxzEGAAEAJQAfAHoCSezg60nsTiOvBwgD3xOPEwwFSO0a AC8A///3/wAACAPfE8cDAAD//wAAHwAgAPLrCiavBxjsxzF6At8TUezHMeDsJwHXExjsxzGLax8B jxPg7EsB1xPc7McxSO3HMRjsxzEBAACAQXBwRXZlbnRzXFNjaGVtZXNcQXBwc1wuRGVmYXVsdFxN QUdJQ01lbnVDb21tYW5kXC5DdXJyZW50AAngAACDAP4ABgG3BbDsS3tXBIj6twVwLtcFIQDwAAEA BgAfAEMBAAAAACYAHwAAANYUBQDEFvcXOvqsAx8DqAdDAR8AJgAlACcAHwAmACUAJwAAAK41AADE Na41jwcfAgAAAADHAP1VrjUCAAAAAgCvNQDzrjUGGwcL4uzAHZUG9xf7Bq41AABI7boAAAA27TgC SO3HMfTsxzEbA98TAACuNU1BR0lDTWVudUNvbW1hbmQAAwAAQO0tJG8YAAD+////BRAczyRFAgDH MSRFAgDC7gIAiwAAANYUDQBa+AAAACAFANztnQOTAAEQSO3HMQwF9xcAAAD///8FEBzPFAIkRQIA VAAM7hQL9zUAAP7///8FEBzPFAIQAhIAAAB+7RkAQwEYABkArwsvASwAAAAAFQATAAAIgQARCBxI sKDBgwgTEgTAkKHChQASSDyQAMBDBAAIHFCwcSMBiwoBFFBQYAGDkwUACEgI4ECBlxsLMBgJ8qDI Ai5fynxZ0yCABSWDAgXas2DLkUFJ0mQ5IChMnEV9EtCJ08DHqEZv8ryJNatDlTwvGp2aUuxCsl1Z BnBodiDbtgcDAgA7 } #End Loader ########################### #Image Image loader set imeye { R0lGODdhFAARAPcAAAAAAAAAVW1tVZKSVQAAqm1tqpKSqra2qtvbqrOzswAA/////7cFBwCu68cx XwA/ADr65gUAAHLrAAEFAAAApG0/A0L2AgBk6wIACAD/AacrAAABAMk7AADzAuA/AAAAAAAAAAAA AEAGAAAAAAAA9wPWFE4ifwMJAAAA1hRC9gIAkOwCAAAyVwQBAA5gAAAAAAAAVuvHMZD2twVQUiAD WAJABgEQAAAAAEAGAAAAAAAAAAAAABMBCeAABDAA1hQfBR8DWAUfAwAAAAACAOrrAgAIAB8BpysA AAEANQIBAQYAAQAAANYUZAAAAAIANQIAAC8AFAAaAFYAJwBlAAAAAAAAQPdeAAC3BSHsAAAAAAAA AADHMQAAAADc68cxkPa3BUIAnhcEAMjsxzEGAAEAJQAfAHoCSezg60nsTiOvBwgD3xOPEwwFSO0a AC8A///3/wAACAPfE8cDAAD//wAAHwAgAPLrCiavBxjsxzF6At8TUezHMeDsJwHXExjsxzGLax8B jxPg7EsB1xPc7McxSO3HMRjsxzEBAACAQXBwRXZlbnRzXFNjaGVtZXNcQXBwc1wuRGVmYXVsdFxN QUdJQ01lbnVDb21tYW5kXC5DdXJyZW50AAngAACDAP4ABgG3BbDsS3tXBJD2twVwLtcFIQDwAAEA BgAfAEMBAAAAACYAHwAAANYUBQDEFvcXQvasAx8DMApDAR8AJgAlACcAHwAmACUAJwAAAK41AADE Na41jwcfAgAAAADHAP1VrjUCAAAAAgCvNQDzrjUGGwcL4uzAHZUG9xf7Bq41AABI7boAAAA27TgC SO3HMfTsxzEbA98TAACuNU1BR0lDTWVudUNvbW1hbmQAAwAAQO0tJG8YAAD+////BRAczyRFAgDH MSRFAgDC7gIAiwAAANYUDQA6+gAAACAFANztnQOTAAEQSO3HMQwF9xcAAAD///8FEBzPFAIkRQIA VAAM7hQL9zUAAP7///8FEBzPFAIQAhIAAAB+7RkAQwEYABkA7wsvASwAAAAAFAARAAAIewATCBxI sKBBggASKlR4UODChwsNQgRQkCHCiQkvVlRooGJDjAkFCKD4UWEAAgE4ktyYkIBLAghUsjQgQMHJ kwUWRByocOQBlCgPLNCZ8SKAAzSDDt3pEABNAwAGGJBqAGpRowaQGihw4IBFiQsFFBhwtWECiGbB li0YEAA7 } ####################### #Image Help set imhelp { R0lGODdhDgARAPcAAAAAAAAAVQAAqgAA/wAkAAAkVQAkqgAk/wBJAABJVQBJqgBJ/wBtAABtVQBt qgBt/wCSAACSVQCSqgCS/wC2AAC2VQC2qgC2/wDbAADbVQDbqgDb/wD/AAD/VQD/qgD//yQAACQA VSQAqiQA/yQkACQkVSQkqiQk/yRJACRJVSRJqiRJ/yRtACRtVSRtqiRt/ySSACSSVSSSqiSS/yS2 ACS2VSS2qiS2/yTbACTbVSTbqiTb/yT/ACT/VST/qiT//0kAAEkAVUkAqkkA/0kkAEkkVUkkqkkk /0lJAElJVUlJqklJ/0ltAEltVUltqklt/0mSAEmSVUmSqkmS/0m2AEm2VUm2qkm2/0nbAEnbVUnb qknb/0n/AEn/VUn/qkn//20AAG0AVW0Aqm0A/20kAG0kVW0kqm0k/21JAG1JVW1Jqm1J/21tAG1t VW1tqm1t/22SAG2SVW2Sqm2S/222AG22VW22qm22/23bAG3bVW3bqm3b/23/AG3/VW3/qm3//5IA AJIAVZIAqpIA/5IkAJIkVZIkqpIk/5JJAJJJVZJJqpJJ/5JtAJJtVZJtqpJt/5KSAJKSVZKSqpKS /5K2AJK2VZK2qpK2/5LbAJLbVZLbqpLb/5L/AJL/VZL/qpL//7YAALYAVbYAqrYA/7YkALYkVbYk qrYk/7ZJALZJVbZJqrZJ/7ZtALZtVbZtqrZt/7aSALaSVbaSqraS/7a2ALa2Vba2qra2/7bbALbb Vbbbqrbb/7b/ALb/Vbb/qrb//9sAANsAVdsAqtsA/9skANskVdskqtsk/9tJANtJVdtJqttJ/9tt ANttVdttqttt/9uSANuSVduSqtuS/9u2ANu2Vdu2qtu2/9vbANvbVdvbqtvb/9v/ANv/Vdv/qtv/ //8AAP8AVf8Aqv8A//8kAP8kVf8kqv8k//9JAP9JVf9Jqv9J//9tAP9tVf9tqv9t//+SAP+SVf+S qv+S//+2AP+2Vf+2qv+2///bAP/bVf/bqv/b////AP//Vf//qv///yH5BAAAAAAALAAAAAAOABEA QAiLAP8JHEiwYJt/3/7x+zZgwEJbAApKNIjwX8OG3P5BFChnIDcBAxRqjPjv4L99/P5t+4etTaSB jQQ2lBly47+OCTP+85fSZhtbQIMKJSkpkqRGRd1IWkrwYMaEKb8BmCrQjcKZ/GbajCNSILcBAkYK jMltH8OQAm1aTfkPpFmx/7iy7Qp3qt27dv8FBAA7 } #End Image Help image create photo imnew -data $imnew -gamma 1 -height 16 -width 16 -palette 5/5/4 image create photo imopen -data $imopen -gamma 1 -height 16 -width 16 -palette 5/5/4 image create photo imsave -data $imsave -gamma 1 -height 16 -width 16 -palette 5/5/4 image create photo imselectall -data $imselectall #-gamma 1 -palette 5/5/4 image create photo imcopy -data $imcopy -gamma 1 -height 16 -width 16 -palette 5/5/4 image create photo imcut -data $imcut -gamma 1 -height 16 -width 16 -palette 5/5/4 image create photo impaste -data $impaste -gamma 1 -height 16 -width 16 -palette 5/5/4 image create photo imprint -data $imprint image create photo improtocol -data $improtocol image create photo imchart -data $imchart image create photo imeye -data $imeye image create photo imhelp -data $imhelp frame .ed.menubuttons -relief groove -borderwidth 1 pack .ed.menubuttons -side top -fill x -expand yes button .ed.menubuttons.new -image imnew -command {clear_all .ed.text.t} button .ed.menubuttons.open -image imopen -command "clear_all .ed.text.t ; textOpen" button .ed.menubuttons.save -image imsave -command "textSaveAs" button .ed.menubuttons.selectall -image imselectall -height 16 -width 16 -command {.ed.text.t tag add sel 1.0 end} button .ed.menubuttons.copy -image imcopy -command {tk_textCopy .ed.text.t} button .ed.menubuttons.cut -image imcut -command "tk_textCut .ed.text.t" button .ed.menubuttons.paste -image impaste -command "tk_textPaste .ed.text.t" button .ed.menubuttons.print -image imprint -command "printFormat" -width 16 -height 16 button .ed.menubuttons.run -image improtocol -command {run_tcl .ed.text.t} -width 16 -height 16 button .ed.menubuttons.help -image imhelp -command "About" -width 16 -height 16 label .ed.menubuttons.l -text "" -font {Arial 8 normal} pack .ed.menubuttons.new .ed.menubuttons.open .ed.menubuttons.save .ed.menubuttons.print .ed.menubuttons.selectall .ed.menubuttons.copy .ed.menubuttons.cut .ed.menubuttons.paste .ed.menubuttons.run .ed.menubuttons.help -side left -fill x pack .ed.menubuttons.l -side left -fill x ##################################### bind .ed.menubuttons.new <Enter> ".ed.menubuttons.l config -text {New}" bind .ed.menubuttons.new <Leave> ".ed.menubuttons.l config -text {}" bind .ed.menubuttons.open <Enter> ".ed.menubuttons.l config -text {Open File}" bind .ed.menubuttons.open <Leave> ".ed.menubuttons.l config -text {}" bind .ed.menubuttons.save <Enter> ".ed.menubuttons.l config -text {Save as...}" bind .ed.menubuttons.save <Leave> ".ed.menubuttons.l config -text {}" bind .ed.menubuttons.selectall <Enter> ".ed.menubuttons.l config -text {Select all}" bind .ed.menubuttons.selectall <Leave> ".ed.menubuttons.l config -text {}" bind .ed.menubuttons.copy <Enter> ".ed.menubuttons.l config -text {Copy selected text}" bind .ed.menubuttons.copy <Leave> ".ed.menubuttons.l config -text {}" bind .ed.menubuttons.cut <Enter> ".ed.menubuttons.l config -text {Cut selected text}" bind .ed.menubuttons.cut <Leave> ".ed.menubuttons.l config -text {}" bind .ed.menubuttons.paste <Enter> ".ed.menubuttons.l config -text {Paste selected text}" bind .ed.menubuttons.paste <Leave> ".ed.menubuttons.l config -text {}" bind .ed.menubuttons.print <Enter> ".ed.menubuttons.l config -text {Print formated text}" bind .ed.menubuttons.print <Leave> ".ed.menubuttons.l config -text {}" bind .ed.menubuttons.run <Enter> ".ed.menubuttons.l config -text {Run Tcl}" bind .ed.menubuttons.help <Enter> ".ed.menubuttons.l config -text {Help}" bind .ed.menubuttons.help <Leave> ".ed.menubuttons.l config -text {}" ##################################### #Text widget frame .ed.text text .ed.text.t -wrap none -font {monaco 12} -cursor arrow -yscrollcommand {.ed.text.scrl set} -xscrollcommand {.ed.text.scrl2 set} scrollbar .ed.text.scrl -command ".ed.text.t yview" scrollbar .ed.text.scrl2 -command ".ed.text.t xview" -orient hor pack .ed.text.scrl -side right -fill y pack .ed.text.scrl2 -side bottom -fill x pack .ed.text.t -fill both -expand yes pack .ed.text -side left -fill both -expand true bind .ed.text <Enter> "focus .ed.text" } proc About {} { catch [destroy .about] toplevel .about wm resizable .about 0 0 center_win .about grab .about label .about.l -relief groove -bd 3 -font {arial 11 {bold}} -text "n TkMC v1.0n Author: Grigoriy Abramovn System Administrator of The Center For Population Economics n The University of Chicagon Questions and bug report send to: n gabramov@cpe.uchicago.edun " pack .about.l bind .about <Enter> "destroy .about" }
E) Un bloc note
voici le code:
#! /usr/local/tcl/bin/wish # ---- faire le menage en cas de re-chargement catch {font delete textFont} catch {eval destroy [winfo children .]} catch {unset HiddenText} # ---- creer la fenetre d'edition de texte # font create textFont -family Courier -size 10 text .src -font textFont -width 80 -height 40 -relief sunken -yscrollcommand {.sb set} scrollbar .sb -orient vertical -command {.src yview} pack .src -side left -fill both -expand true pack .sb -side left -fill y # ---- creer la barre de menus # menu .bar .bar add cascade -label Fichier -menu .bar.text .bar add cascade -label Edition -menu .bar.edit #.bar add cascade -label Tcl -menu .bar.tcl . config -menu .bar menu .bar.text .bar.text add command -label Nouveau -command {NewText} .bar.text add command -label Charger -command {OpenFile} .bar.text add command -label Sauver -command {SaveFile} .bar.text add command -label "Sauver sous" -command {SaveAs} .bar.text add separator .bar.text add command -label Quit -command {Quit} menu .bar.edit .bar.edit add command -label Couper -command {event generate <<Cut>>} .bar.edit add command -label Copier -command {event generate <<Copy>>} .bar.edit add command -label Coller -command {event generate <<Paste>>} .bar.edit add separator .bar.edit add command -label "Outline selection" -command {CreateSelectOutline} .bar.edit add command -label "Outline Tcl proc" -command {CreateTclProcOutline} #menu .bar.tcl #.bar.tcl add command -label "Nouvel interpreteur" -command {NewInterp} #.bar.tcl add command -label Evaluer -command {EvalText} #.bar.tcl add command -label "Espionner variable" -command {SpyVar} # ---- procedures de gestion de fichiers # # Attention! on ne controle pas si le fichier en cours d'edition a ete modifie... # set fileName "" proc NewText {} { global fileName .src delete 1.0 end set fileName "" } proc OpenFile {} { global fileName set types { {{Text Files} {} TEXT} {{TCL Scripts} {.tcl}} } set fileName [tk_getOpenFile -filetypes $types] if {$fileName == ""} return if [catch {open $fileName r} fd] { tk_messageBox -title "Erreur" -type ok -icon error -message $fd return } .src delete 1.0 end .src insert end [read $fd [file size $fileName]] close $fd } proc SaveFile {} { global fileName if {$fileName == ""} { SaveAs return } if [catch {open $fileName w} fd] { tk_messageBox -title "Erreur" -type ok -icon error -message $fd return } catch {.src delete reply.first reply.last} puts -nonewline $fd [.src get 1.0 end] close $fd } proc SaveAs {} { global fileName set types { {{Text Files} {} TEXT} {{TCL Scripts} {.tcl}} } set fileName [tk_getSaveFile -filetypes $types] if {$fileName == ""} return if [catch {open $fileName w} fd] { tk_messageBox -title "Erreur" -type ok -icon error -message $fd return } catch {.src delete reply.first reply.last} puts -nonewline $fd [.src get 1.0 end] close $fd } proc Quit {} { destroy . } # --- boite de recherche # toplevel .find wm title .find Find entry .find.string button .find.show -text Show -command {ShowFindString [.find.string get]} button .find.reset -text Reset -command ResetFindString bind .find.string <Key-Return> {ShowFindString [.find.string get]} bind .find.string <Key> {AutoFind} proc AutoFind {} { global findId after cancel AutoFind after 500 {ShowFindString [.find.string get]} } pack .find.string -side top -fill x pack .find.show -side left -padx 5 -pady 5 pack .find.reset -side left -padx 5 -pady 5 proc ShowFindString {str} { set from 1.0 ResetFindString .src tag configure found -background green while { [set from [.src search -exact -count length -- $str $from end]] != {} } { set to [.src index "$from + $length chars"] .src tag add found $from $to set from $to } } proc ResetFindString {} { .src tag delete found } # ---- mode outline # set wid 0 proc CreateSelectOutline {} { set from [.src index sel.first] set to [.src index sel.last] if [.src compare $from == $to] { return } CreateOutline $from $from $to } proc CreateTclProcOutline {} { set from [.src search -back -regexp -- "^proc " insert 1.0] set to [.src search -forw -regexp -- "^}" insert end] if {$from == {} || $to == {}} { return } CreateOutline $from [.src index "$from lineend"] $to } proc CreateOutline {mark from to} { global wid incr wid set w [button .src.w$wid -text v -command "ToggleOutline $wid"] .src window create $mark -window $w .src mark set b$wid "$from +1char" .src mark set e$wid "$to + 1char" .src mark gravity b$wid left ToggleOutline $wid } proc ToggleOutline {wid} { global HiddenText if [info exists HiddenText($wid)] { .src insert b$wid $HiddenText($wid) unset HiddenText($wid) .src.w$wid config -text v } else { set HiddenText($wid) [.src get b$wid e$wid] .src delete b$wid e$wid .src.w$wid config -text > } }
F) Un logiciel de dessin façon paintbrush
voici le code :
# Name: ScratchPad.tcl # Author: Martin Eder, snofix@users.sourceforge.net # Description: A simple scratch pad which provides free-hand drawing and # basic geometric figures (lines, rectangels, circles). # The drawing can be saved as jpg or gif file. namespace eval spad { set currentmode "freehand" set thickness 1 set thicklist "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 22 24 26 28 30" set pcolor "black" set pbcolor "white" set canbg "white" set savename "" } proc spad::setcol {cvar widget} { set newcolor [tk_chooseColor -initialcolor $cvar -parent .ppad -title "Choose new fill color"] if {$newcolor != ""} { set $cvar $newcolor $widget configure -bg $newcolor return $newcolor } } proc spad::gui {} { if {[winfo exists .ppad]} {destroy .ppad} wm withdraw . toplevel .ppad -padx 5 -pady 5 wm protocol .ppad WM_DELETE_WINDOW exit wm title .ppad "Scratch Pad" frame .ppad.f -relief ridge -borderwidth 4 canvas .ppad.f.c -bg $spad::canbg -highlightthickness 0 -width 320 -height 240 frame .ppad.panel frame .ppad.dpanel frame .ppad.status label .ppad.status.pos -relief groove -width 9 label .ppad.status.size -relief groove -width 9 label .ppad.status.bar -relief groove -anchor w -width 10 label .ppad.panel.pcollab -text " Pen:" button .ppad.panel.pcol -width 3 -bg $spad::pcolor -relief ridge -command { set tmpcol [spad::setcol $spad::pcolor .ppad.panel.pcol] if {$tmpcol != ""} {set spad::pcolor $tmpcol} } label .ppad.panel.pbcollab -text " Fill:" button .ppad.panel.pbcol -width 3 -bg $spad::pbcolor -relief ridge -command { set tmpcol [spad::setcol $spad::pbcolor .ppad.panel.pbcol] if {$tmpcol != ""} {set spad::pbcolor $tmpcol} } label .ppad.panel.bgcollab -text " Background:" button .ppad.panel.bgcol -width 3 -bg $spad::canbg -relief ridge -command { set tmpcol [spad::setcol $spad::canbg .ppad.panel.bgcol] if {$tmpcol != ""} { .ppad.f.c configure -bg [set spad::bgcollab $tmpcol] } } spinbox .ppad.dpanel.thickness -values $spad::thicklist -command {set spad::thickness [.ppad.dpanel.thickness get]} -state readonly -width 3 button .ppad.dpanel.pointer -relief raised -command spad::pointer -image [image create photo -data { R0lGODlhEAAQAIMAAPwCBAQCBPz+xPz+BMTCBPz+/MTCxISChDQyNAAAAAAA AAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAREEMhJg6BYWhAG v5k2EKMXToSgEqc1DEIhvGAWpOvJFSXZyoXOxxY0BDahQDGg4xgOxmbgiWDq poeqlGrVcZuSbLfpjwAAIf5oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8gdmVy c2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwgcmlnaHRzIHJl c2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==}] button .ppad.dpanel.freehand -relief raised -command spad::draw_free -image [image create photo -data { R0lGODlhEgASAIAAAAAAAP///yH5BAEAAAEALAAAAAASABIAAAIjjI+pywgP moty1kTvyTpw/UHfRkGGqYhpt7Gn67GopMK2UgAAOw==}] button .ppad.dpanel.line -relief raised -command spad::draw_line -image [image create photo -data { R0lGODlhEgASAIAAAAAAAP///yH5BAEAAAEALAAAAAASABIAAAIdjI+py+0G wEtxUmlPzRDnzYGfN3KBaKGT6rDmGxQAOw==}] button .ppad.dpanel.rectangle -relief raised -command spad::draw_rectangle -image [image create photo -data { R0lGODlhEgASAIAAAAAAAP///yH5BAEAAAEALAAAAAASABIAAAImjI+py+3f gJxUqorB1csmv4Udh4AfeZglaqgpG7gtnFVbLUP6/hQAOw==}] button .ppad.dpanel.circle -relief raised -command spad::draw_circle -image [image create photo -data { R0lGODlhEgASAIAAAAAAAP///yH5BAEAAAEALAAAAAASABIAAAIrjI+pywkP X4sULKgw0tluz0iHGIIBeZlo9zWnarLjOnfxe+NVbuy8CwwWAAA7}] .ppad configure -menu [menu .ppad.padmenu] -padx 5 -pady 5 .ppad.padmenu add cascade -label "File" -menu [menu .ppad.padmenu.file -tearoff 0] .ppad.padmenu.file add command -label "Clear" -command {.ppad.f.c delete all} .ppad.padmenu.file add command -label "Save" -command {spad::save_can $spad::savename} .ppad.padmenu.file add command -label "Save As" -command {spad::save_can ""} .ppad.padmenu.file add separator .ppad.padmenu.file add command -label "About" -command {tk_messageBox -title "About" -message "Scratch Padn2006 by Martin Edern(snofix@users.sourceforge.net)"} .ppad.padmenu.file add command -label "Exit" -command exit pack .ppad.f.c -expand 1 -fill both pack .ppad.dpanel.pointer .ppad.dpanel.freehand .ppad.dpanel.line .ppad.dpanel.rectangle .ppad.dpanel.circle -padx 2 -side top -pady 1 -fill x pack .ppad.dpanel.thickness -side top -pady 10 -padx 2 -fill x pack .ppad.panel.pcollab .ppad.panel.pcol .ppad.panel.pbcollab .ppad.panel.pbcol .ppad.panel.bgcollab .ppad.panel.bgcol -side left pack .ppad.status.size .ppad.status.pos -side right pack .ppad.status.bar -side left -expand 1 -fill x pack .ppad.status -side bottom -fill x pack .ppad.panel -side bottom -fill x -pady 5 pack .ppad.dpanel -side left -fill y pack .ppad.f -side right -expand 1 -fill both bind .ppad.f.c <3> {.ppad.f.c delete current} bind .ppad.f.c <Configure> {.ppad.status.size configure -text "[winfo width .ppad.f.c]x[winfo height .ppad.f.c]"} bind posupdate <Motion> {spad::update_pos %x %y} bind posupdate <B1-Motion> {spad::update_pos %x %y} bindtags .ppad.f.c {posupdate .ppad.f.c .ppad} ### Help text bind .ppad.dpanel.pointer <Enter> {.ppad.status.bar configure -text "Magic wand. Move a figure by drag and drop."} bind .ppad.dpanel.freehand <Enter> {.ppad.status.bar configure -text "Tool for free-hand drawings. Press the left mouse button and keep it pressed."} bind .ppad.dpanel.line <Enter> {.ppad.status.bar configure -text "Draw lines. Keep the left mouse button pressed to draw the line."} bind .ppad.dpanel.rectangle <Enter> {.ppad.status.bar configure -text "Draw rectangeles. Keep the left mouse button pressed to draw the rectangle."} bind .ppad.dpanel.circle <Enter> {.ppad.status.bar configure -text "Draw ovals. Keep the left mouse button pressed to draw the oval."} bind .ppad.dpanel.thickness <Enter> {.ppad.status.bar configure -text "Change the thickness of the pen."} bind .ppad.panel.pcol <Enter> {.ppad.status.bar configure -text "Change the color of the pen."} bind .ppad.panel.pbcol <Enter> {.ppad.status.bar configure -text "Change the fill color for rectangles and ovals."} bind .ppad.f.c <Enter> {.ppad.status.bar configure -text "Scratch Pad. Right click to delete figures, left mouse button to draw figures."} bind .ppad.status.pos <Enter> {.ppad.status.bar configure -text "Shows x and y position of the pointer."} bind .ppad.status.size <Enter> {.ppad.status.bar configure -text "Shows canvas size in pixels."} } proc spad::pointer {} { spad::draw_mode pointer bind .ppad.f.c <ButtonPress-1> { set startx %x set starty %y set seltag [.ppad.f.c gettag current] puts $seltag} bind .ppad.f.c <B1-Motion> { .ppad.f.c move $seltag [expr %x - $startx] [expr %y - $starty] set startx %x set starty %y } bind .ppad.f.c <ButtonRelease-1> {} } proc spad::draw_free {} { spad::draw_mode freehand bind .ppad.f.c <ButtonPress-1> {set tempfree [.ppad.f.c create line %x %y %x %y -fill $spad::pcolor -width $spad::thickness]} bind .ppad.f.c <B1-Motion> {.ppad.f.c coords $tempfree [concat [.ppad.f.c coords $tempfree] %x %y]} bind .ppad.f.c <ButtonRelease-1> {} } proc spad::draw_line {} { spad::draw_mode line bind .ppad.f.c <ButtonPress-1> { set linestartx %x set linestarty %y set tline [.ppad.f.c create line $linestartx $linestarty %x %y -width $spad::thickness -fill $spad::pcolor] } bind .ppad.f.c <B1-Motion> {.ppad.f.c coord $tline $linestartx $linestarty %x %y} bind .ppad.f.c <ButtonRelease-1> {.ppad.f.c coord $tline $linestartx $linestarty %x %y} } proc spad::draw_rectangle {} { spad::draw_mode rectangle bind .ppad.f.c <ButtonPress-1> { set rectstartx %x set rectstarty %y set trect [.ppad.f.c create rectangle $rectstartx $rectstarty %x %y -width $spad::thickness -fill $spad::pbcolor -outline $spad::pcolor] } bind .ppad.f.c <B1-Motion> {.ppad.f.c coord $trect $rectstartx $rectstarty %x %y} bind .ppad.f.c <ButtonRelease-1> {.ppad.f.c coord $trect $rectstartx $rectstarty %x %y} } proc spad::draw_circle {} { spad::draw_mode circle bind .ppad.f.c <ButtonPress-1> { set circstartx %x set circstarty %y set tcirc [.ppad.f.c create oval $circstartx $circstarty %x %y -width $spad::thickness -fill $spad::pbcolor -outline $spad::pcolor] } bind .ppad.f.c <B1-Motion> {.ppad.f.c coord $tcirc $circstartx $circstarty %x %y} bind .ppad.f.c <ButtonRelease-1> {.ppad.f.c coord $tcirc $circstartx $circstarty %x %y} } proc spad::draw_mode {widget} { .ppad.dpanel.$::spad::currentmode configure -relief raised .ppad.dpanel.$widget configure -relief sunken set ::spad::currentmode $widget } proc spad::save_can {filename} { if {[catch {package require Img} err]} { tk_messageBox -message "Could not load package Img!" -icon error return } set canimg [image create photo -format window -data .ppad.f.c] if {$filename == ""} { set filename [tk_getSaveFile -title "Save Scratch Pad" -filetypes ""{GIF Image} {.gif}" "{JPEG Image} {.jpg}"" -initialdir [pwd] -initialfile "ScratchPad.gif"] } if {$filename != ""} { switch -- [file extension $filename] { ".gif" {set fformat "GIF"} ".jpg" {set fformat "JPEG"} default {tk_messageBox -title "Unsupported format" -message "Unsupported format.nPlease use gif or jpg extension.n" -icon error; return} } $canimg write $filename -format $fformat } set spad::savename $filename } proc spad::update_pos {xp yp} { set offset 0 set xpos [expr $xp - $offset] set ypos [expr $yp - $offset] .ppad.status.pos configure -text "$xpos,$ypos" } spad::gui spad::draw_free spad::update_pos 0 0 ### End of Script
G) Un convertisseur de base (binaire, décimal, octal, hexa,etc...)
Voici le code :
#!/bin/sh # # $Id: tkalc.tcl,v 1.4 2001/01/11 13:35:43 boris Exp $ # tkalc - Programmer's almighty pocket calculator # Copyright (C) 2000 Boris Folgmann # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # the next line restarts using wish exec wish "$0" "$@" # Globals set expression "" set VERSION "tkalc 1.0.2" set decimal "Welcome to tkalc!" set hexadecimal "Enter expression and press return." set octal "Press Esc to close window." set binary "Alt+C for Clear and so on" set ascii "Tab to change widget, space to push button" set ip "Check out http://www.folgmann.de" set bool "Email: boris@folgmann.de" set errormsg "tkalc (c) 2000-2001 by Boris Folgmann" # I use this as a constant for the widget width in characters set WIDTH 38 # Set window title # . is always the toplevel widget wm title . $VERSION wm grid . 45 20 10 10 wm minsize . 45 20 wm resizable . 1 0 # Set defaults . config -borderwidth 3 # Make main frame set m [frame .main] grid columnconf $m 1 -weight 1 # Make buttons frame set b [frame .buttons] # Center at top grid $m $b -sticky new # Use 5:1 for output against buttons grid columnconf . 0 -weight 5 grid columnconf . 1 -weight 1 # expression entry label $m.lexpression -text Expr -padx 0 # The increased borderwidth is needed so that the ridge border is as thick as the sunken border. entry $m.expression -width $WIDTH -relief ridge -borderwidth 3 -background white -textvariable expression grid $m.lexpression $m.expression -padx 3 -pady 1 -sticky news # Decimal label $m.ldec -text Dec -padx 0 label $m.dec -width $WIDTH -relief sunken -textvariable decimal grid $m.ldec $m.dec -padx 3 -pady 1 -sticky news # Use sticky west for left centered labels! # -sticky w # Hex label $m.lhex -text Hex -padx 0 label $m.hex -width $WIDTH -relief sunken -textvariable hexadecimal grid $m.lhex $m.hex -padx 3 -pady 1 -sticky news # Oct label $m.loct -text Oct -padx 0 label $m.oct -width $WIDTH -relief sunken -textvariable octal grid $m.loct $m.oct -padx 3 -pady 1 -sticky news # Bin label $m.lbin -text Bin -padx 0 label $m.bin -width $WIDTH -relief sunken -textvariable binary grid $m.lbin $m.bin -padx 3 -pady 1 -sticky news # ASCII label $m.lascii -text ASCII -padx 0 label $m.ascii -width $WIDTH -relief sunken -textvariable ascii grid $m.lascii $m.ascii -padx 3 -pady 1 -sticky news # IP label $m.lip -text IP -padx 0 label $m.ip -width $WIDTH -relief sunken -textvariable ip grid $m.lip $m.ip -padx 3 -pady 1 -sticky news # Bool label $m.lbool -text Bool -padx 0 label $m.bool -width $WIDTH -relief sunken -textvariable bool grid $m.lbool $m.bool -padx 3 -pady 1 -sticky news # Error label $m.lerr -text Status -padx 0 label $m.err -width $WIDTH -relief sunken -textvariable errormsg grid $m.lerr $m.err -padx 3 -pady 1 -sticky news # buttons button $b.eval -text Evaluate -underline 0 -command Eval button $b.clear -text Clear -underline 0 -command Clear button $b.nums -text Numbers -underline 0 -command Nums button $b.ops -text Operators -underline 0 -command Ops button $b.funcs -text Functions -underline 0 -command Funcs button $b.about -text About -underline 0 -command About button $b.quit -text Quit -underline 0 -command exit # Stick all to left and right edge, so they have the same width! grid columnconf $b 0 -weight 1 grid $b.eval -sticky new grid $b.clear -sticky new grid $b.nums -sticky new grid $b.ops -sticky new grid $b.funcs -sticky new grid $b.about -sticky new grid $b.quit -sticky new # Set keybindings and inital focus bind . <Escape> exit bind . <Alt-e> Eval bind . <Alt-c> Clear bind . <Alt-n> Nums bind . <Alt-o> Ops bind . <Alt-f> Funcs bind . <Alt-a> About bind . <Alt-q> exit bind $m.expression <Return> Eval # We need -force here, otherwise the main windows doesn't get active # when running on Win98 focus -force $m.expression # Procedures starting here proc Clear {} { global expression set expression "" } proc ip {ip} { if {[regexp "([^.]+)\.([^.]+)\.([^.]+)\.([^.]+)" $ip m a b c d]} { if {[string equal "$ip" "$m"]} { if {[expr {$a > 255 || $b > 255 || $c > 255 || $d > 255}]} { error "max component size of IP address is 255" } return [expr {$a << 24 | $b << 16 | $c << 8 | $d}] } } error "not a valid IP address" } proc bin {bin} { set result 0 for {set i 0} {$i < [string length $bin]} {incr i} { set digit [string index $bin $i] if {$digit == 0 || $digit == 1} { set result [expr {$result << 1 | $digit}] } elseif {$digit == "."} { #ignore } else { error "not a valid binary digit" } } return $result } # Evaluate expression proc Eval {} { # say what global vars you want to use # if you forget it here, you will use a local var global expression decimal hexadecimal octal binary ascii ip bool global errormsg m m.err if {[SafeExpr $expression]} { set decimal $result if {[SafeExpr int($result)]} { set hexadecimal [format "%#010x" [expr {$result}]] set octal [format "%#o" [expr {$result}]] set binary [DecToBin [expr {$result}]] set ascii [format ""%s%s%s%s"" [Char [expr {$result} >> 24 & 0xff]] [Char [expr {$result} >> 16 & 0xff]] [Char [expr {$result} >> 8 & 0xff]] [Char [expr {$result} & 0xff]]] set ip [format "%s.%s.%s.%s" [expr {$result} >> 24 & 0xff] [expr {$result} >> 16 & 0xff] [expr {$result} >> 8 & 0xff] [expr {$result} & 0xff]] if {int($result)} { set bool "True" } else { set bool "False" } } } else { set decimal "" } } proc SafeExpr {exp} { global expression decimal hexadecimal octal binary ascii ip bool global errormsg m m.err # uplevel is used to access callers result variable! if {[catch {uplevel "set result [expr $exp]"} errormsg]} { #catch returns non-zero on error $m.err config -foreground red bell set hexadecimal "" set octal "" set binary "" set ascii "" set ip "" set bool "" return 0 } else { #catch returns zero on success set errormsg "Ok" #default would be better than black! $m.err config -foreground black return 1 } } proc Char {byte} { if {$byte >= 32 && $byte <= 126} { return [format "%c" $byte] } else { return "." } } proc ByteToBin {byte} { for {set i 0} {$i < 8} {incr i} { append result [format "%d" [expr {($byte & 0x80) >> 7}]] set byte [expr {$byte << 1}] } return $result } proc DecToBin {dec} { append result [ByteToBin [expr {$dec >> 24 & 0xff}]] "." [ByteToBin [expr {$dec >> 16 & 0xff}]] "." [ByteToBin [expr {$dec >> 8 & 0xff}]] "." [ByteToBin [expr {$dec & 0xff}]] return $result } proc About {} { global tcl_platform set title "About" set text "tkalc (c) 2000 by Boris Folgmann. Released under the GPL (General Public License) For latest version check out http://www.folgmann.de Send bug reports and suggestions to: boris@folgmann.de " switch $tcl_platform(platform) { unix { DisplayText $title $text } windows { set choice [tk_messageBox -title "tkalc: About" -message $text] } } } proc DisplayText {name text} { global tcl_platform m # the w prefix is randomly choosen! if {[winfo exists .w$name]} { wm deiconify .w$name focus .w$name return } set numlines [regsub -all n $text {} ignore] switch $tcl_platform(platform) { unix { set font {fixed} } windows { set font {systemfixed} } } set w [toplevel .w$name -borderwidth 3] append title "tkcalc: " $name wm title $w $title focus .w$name bind $w <Escape> {destroy %W} bind $w <Destroy> {focus -force $m.expression} # Create connected text and scrollbar widget scrollbar $w.yscroll -command "$w.text yview" -orient vertical text $w.text -yscrollcommand "$w.yscroll set" -wrap word -font $font -width 54 -height $numlines # Pack scrollbar first! Otherwise its clipped for small windows pack $w.yscroll -side right -fill y pack $w.text -side left -fill both -expand true # set read only text $w.text config -state normal $w.text insert end $text $w.text config -state disabled } proc Nums {} { DisplayText "Numbers" "Valid numbers are: DescriptiontExample Decimaltt42 Floattt34.235 Scientifict45.12e5 Hextt0xdeadbeef Octaltt0774 (leading zero) Binarytt[bin 1000.1111] (place dots at will) IP addresst[ip 192.168.41.1] " } proc Ops {} { DisplayText "Operators" "Operators from highest to lowest precedence: * ~ !ttUnary minus, bitwise NOT, logical NOT * / %ttMultiply, divide, remainder + -ttAdd, subtract << >>ttLeft shift, right shift < > <= >=tLess, greater, less or equal, ttgreater or equal == !=ttEqual, not equal &ttBitwise AND ^ttBitwise XOR |ttBitwise OR &&ttLogical AND ||ttLogical OR x?y:zttIf x then y else z " } proc Funcs {} { DisplayText "Functions" "Available functions are: acos(x) asin(x) atan(x) atan2(y,x) ceil(x) cos(x) cosh(x) exp(x) floor(x) fmod(x,y) hypot(x,y) log(x) log10(x) pow(x,y) sin(x) sinh(x) sqrt(x) tan(x) tanh(x) abs(x) double(x) int(x) round(x) rand() srand(x) " }
Conclusion
Rien à voir avec gambas je vous l'accorde, mais je veux vous montrer que vous pouvez développer des applications de façon simple et rapide avec Linux.