dc 10/06/08 (Il fallait bien donner un nom à ça...)
Voici donc un petit package appelé vHF, qui permet d'accéder à un widget volumeHF. L'obtention des couleurs dégradées se fait grâce à http://wiki.tcl.tk/9079
Code
# auteur : david cobac [string map {# @} david.cobac#gmail.com] # date : 11/06/2008 bind VhfScale <4> [list ::vHF::incremente %W] bind VhfScale <5> [list ::vHF::decremente %W] bind VhfScale <Destroy> [list ::vHF::destruction %W] bind VhfScale <Enter> [list ::vHF::entrer %W] bind VhfScale <Leave> [list ::vHF::partir %W] # namespace eval ::vHF { variable version 1.2.1 variable {} variable pi [expr {acos(-1)}] # package provide vHF $version # namespace export * # array set {} { -chfn 8 -chfnColor gray30 -chfnGColor1 green -chfnGColor2 red -chfnGradient 1 -chfnLines 1 -chfnLWidth 1 -chfnLNb 40 -diam 100 -disp 1 -dispColor white -dispGColor1 green -dispGColor2 red -dispGradient 1 -end 135 -format %.1f -from 0 -length 20 -resolution 1 -repColor red -start -135 -to 100 -value 0 -variable {} -width 2 } set (-bg) [ttk::style lookup TFrame -background] set (-activefg) [ttk::style lookup TFrame -background active] set (-fg) [ttk::style lookup TScale -background] } proc ::vHF::volumeHF {{w ""} args} { variable {} foreach key [array names {} -*] { set ($w:$key) $($key) } # ttk::frame $w -class VhfScale canvas $w.cv -bd 0 -highlightt 0 -bg $($w:-bg) pack $w.cv -expand 1 -fill both bind $w.cv <4> [list event generate $w <4>] bind $w.cv <5> [list event generate $w <5>] bind $w.cv <Enter> [list event generate $w <Enter>] bind $w.cv <Leave> [list event generate $w <Leave>] # on réarrange l'ordre des événements pour être # sûr de traiter le bind de la classe avant bindtags $w [list VhfScale $w . all] # avant de créer une procédure du nom du widget $w # on se permet de récupérer la commande traitant la # frame conteneur rename $w _$w # eval [format { proc ::%s {args} { uplevel 1 ::vHF::operation %s $args } } $w $w] # set ($w:init) 0 if {$args ne ""} { # :init va me servir à savoir si config est appelée # maintenant à la création ou non comme ça j'en déduis # qu'il faudra faire dans config les trois procédures # suivantes set ($w:init) 1 uplevel 1 ::vHF::config $w $args set ($w:init) 0 } else { ::vHF::actualiseVariables $w ::vHF::constructionBouton $w ::vHF::actualiseRepere $w } # return $w } proc ::vHF::destruction {w} { variable {} array unset {} $w:* } proc ::vHF::operation {w {oper ""} args} { switch -glob -- $oper { cge* { uplevel 1 ::vHF::cget $w $args } con* { uplevel 1 ::vHF::config $w $args } default { error "unknown vHF operation '$oper' : should be 'cget' or 'configure'" } } } proc ::vHF::cget {w args} { variable {} if {[llength $args] ne 1} { error "use is '$w cget -option'" } set key [lindex $args 0] switch -glob -- $key { -activefg { return $($w:-activefg) } -bg { return $($w:-bg) } -chfn { return $($w:-chfn) } -chfnC* { return $($w:-chfnColor) } -chfnGColor1 { return $($w:-chfnGColor1) } -chfnGColor2 { return $($w:-chfnGColor2) } -chfnGr* { return $($w:-chfnGradient) } -chfnLi* { return $($w:-chfnLines) } -chfnLN* { return $($w:-chfnLNb) } -chfnLW* { return $($w:-chfnLWidth) } -diam { return $($w:-diam) } -disp { return $($w:-disp) } -dispC* { return $($w:-dispColor) } -dispGColor1 { return $($w:-dispGColor1) } -dispGColor2 { return $($w:-dispGColor2) } -dispGr* { return $($w:-dispGradient) } -end { return $($w:-end) } -fg { return $($w:-fg) } -format { return $($w:-format) } -from { return $($w:-from) } -len* { return $($w:-length) } -repC* { return $($w:-repColor) } -res* { return $($w:-resolution) } -start { return $($w:-start) } -to { return $($w:-to) } -value { return $($w:-value) } -var* { return $($w:-variable) } -wid* { return $($w:-width) } default { return [_$w cget $key] } } } proc ::vHF::config {w args} { variable {} # vérifications if {[llength $args] % 2 != 0} { error "use is '$w configure ?-option value?...'" } # on traite la demande sans option en renvoyant # toutes les valeurs d'options actuellement employées : if {$args eq ""} { set sortie "" foreach {key value} [array get {} *:-*] { regexp {.*:(-.*)} $key -> option lappend sortie [list $option $value] } return $sortie } # modification de la valeur des options # foreach {key value} $args { switch -glob -- $key { -activefg { set ($w:-activefg) $value } -bg { set ($w:-bg) $value $w.cv configure -bg $value } -chfn { if { [string is integer $value] && $value >=0 } { set ($w:-chfn) $value } else { error "$value is not a valid integer for -chfn option" } ::vHF::actualiseVariables $w ::vHF::constructionBouton $w } -chfnC* { set ($w:-chfnColor) $value } -chfnGColor1 { set ($w:-chfnGColor1) $value } -chfnGColor2 { set ($w:-chfnGColor2) $value } -chfnGr* { if { $value eq 0 || $value eq 1 } { set ($w:-chfnGradient) $value } else { error "$value is not a valid integer for -chfnGradient option" } } -chfnLi* { if { $value eq 0 || $value eq 1 } { set ($w:-chfnLines) $value } else { error "$value is not a valid integer for -chfnLines option" } ::vHF::actualiseVariables $w ::vHF::constructionBouton $w } -chfnLN* { if { [string is integer $value] && $value >=0 } { set ($w:-chfnLNb) $value } else { error "$value is not a valid integer for -chfnLNb option" } ::vHF::actualiseVariables $w ::vHF::constructionBouton $w } -chfnLW* { if { [string is integer $value] && $value >=0 } { set ($w:-chfnLWidth) $value } else { error "$value is not a valid integer for -chfnLWidth option" } ::vHF::actualiseVariables $w ::vHF::constructionBouton $w } -diam { if { [string is integer $value] && $value >=0 } { set ($w:-diam) $value } else { error "$value is not a valid integer for -diam option" } ::vHF::actualiseVariables $w ::vHF::constructionBouton $w } -disp { if { $value eq 0 || $value eq 1 } { set ($w:-disp) $value } else { error "$value is not a valid integer for -disp option" } } -dispC* { set ($w:-dispColor) $value } -dispGColor1 { set ($w:-dispGColor1) $value } -dispGColor2 { set ($w:-dispGColor2) $value } -dispGr* { if { $value eq 0 || $value eq 1 } { set ($w:-dispGradient) $value } else { error "$value is not a valid integer for -dispGradient option" } } -end { set ($w:-end) $value } -fg { set ($w:-fg) $value $w.cv itemconfigure ptCercle -fill $value $w.cv itemconfigure rayon -fill $value $w.cv itemconfigure gdCercle -outline $value } -format { set ($w:-format) $value } -from { set ($w:-from) $value if { $($w:-value) < $value } { set ($w:-value) $value } } -len* { if { [string is integer $value] && $value >=0 } { set ($w:-length) $value } else { error "$value is not a valid integer for -length option" } } -repC* { set ($w:-repColor) $value $w.cv itemconfigure repere -fill $value } -res* { # pour s'assurer de la précision dans les angles # on fait de résolution un flottant set ($w:-resolution) [expr {$value * 1.}] } -start { set ($w:-start) $value } -to { set ($w:-to) $value if { $($w:-value) > $value } { set ($w:-value) $value } } -value { if { $value > $($w:-to) } { set value $($w:-to) } elseif { $value < $($w:-from) } { set value $($w:-from) } set ($w:-value) $value # liaison avec l'option -variable if { $($w:-variable) ne "" } { uplevel #0 set $($w:-variable) $value } } -var* { # pour effacer la trace sur la précédente variable set ($w:-variablePrecedente) $($w:-variable) set ($w:-variable) $value ::vHF::miseEnPlaceTrace $w # récupération de la valeur actuelle de cette variable # si elle existe ::vHF::liaisonVariableValue $w } -wid* { if { [string is integer $value] && $value >=0 } { set ($w:-width) $value } else { error "$value is not a valid integer for -width option" } } default { # pour une option inconnue de vHF, elle s'applique # à la frame conteneur _$w configure $key $value } } } ::vHF::actualiseVariables $w if {$($w:init) eq 1} { ::vHF::constructionBouton $w } ::vHF::actualiseRepere $w } proc ::vHF::entrer {w} { variable {} set value $($w:-activefg) $w.cv itemconfigure ptCercle -fill $value $w.cv itemconfigure rayon -fill $value $w.cv itemconfigure gdCercle -outline $value } proc ::vHF::partir {w} { variable {} set value $($w:-fg) $w.cv itemconfigure ptCercle -fill $value $w.cv itemconfigure rayon -fill $value $w.cv itemconfigure gdCercle -outline $value } proc ::vHF::incremente {w} { variable {} set v [expr {$($w:-value) + $($w:-resolution)}] if {$($w:-chfnLines) eq 1 && $($w:-value) < $($w:-to)} { ::vHF::rayonTourne $w -1 } $w configure -value $v } proc ::vHF::decremente {w} { variable {} set v [expr {$($w:-value) - $($w:-resolution)}] if {$($w:-chfnLines) eq 1 && $($w:-value) > $($w:-from)} { ::vHF::rayonTourne $w +1 } $w configure -value $v } # renvoit un angle entre -from et -to # correspondant à la valeur entre -start et -end proc ::vHF::value2angle {w x} { variable {} return [expr { $($w:-start) + 1.*($x - $($w:-from)) *\ ($($w:-end) - $($w:-start)) /\ ($($w:-to) - $($w:-from)) }] } proc ::vHF::rotation {x y xc yc angleDeg} { variable pi set angleRad [expr {$pi*$angleDeg/180}] set xp [expr {$xc+cos($angleRad)*($x-$xc)-sin($angleRad)*($y-$yc)}] set yp [expr {$yc+sin($angleRad)*($x-$xc)+cos($angleRad)*($y-$yc)}] return [list $xp $yp] } proc ::vHF::rayonTourne {w sens} { variable {} ## rotation des rayons du chanfrein set listeRayons [$w.cv find withtag rayon] foreach l $listeRayons { # x0 et y0 sont xc et yc -> on les laisse lassign [$w.cv coords $l] x0 y0 x1 y1 $w.cv coords $l $($w:centrex) $($w:centrey) \ {*}[::vHF::rotation $x1 $y1 $($w:centrex) $($w:centrey) \ [expr {$sens*$($w:uniteRotation)}] ] } } proc ::vHF::liaisonVariableValue {w args} { variable {} if { [catch { set v [uplevel #0 set $($w:-variable)] }] } { # la variable passée n'existe pas encore !! set v 0 } $w configure -value $v } proc ::vHF::miseEnPlaceTrace {w} { variable {} # effacer les traces précédentes if {$($w:-variablePrecedente) ne ""} { uplevel #0 trace remove variable $($w:-variablePrecedente) write \ \{::vHF::liaisonVariableValue $w\} } # mise en place de la trace if {$($w:-variable) ne ""} { uplevel #0 trace add variable $($w:-variable) write \ \{::vHF::liaisonVariableValue $w\} } } proc ::vHF::actualiseVariables {w} { variable {} # pas tout à fait le diamètre ! set ($w:diametreptCercle) [expr {$($w:-diam)-$($w:-chfn)}] # rayon utile pour la proc actualiseRepere set ($w:rayonptCercle) [expr {.5*($($w:diametreptCercle)-$($w:-chfn))}] set ($w:rayonpptCercle) [expr {$($w:rayonptCercle) - $($w:-length)}] # # l'angle de rotation unité est calculée sur la base d'une rotation minimale # correspondant à la résolution (en partant du début), # ensuite une fois cet angle trouvé, on a notre rotation unité en soustrayant # à la position de départ set angleDeg [::vHF::value2angle $w [expr {$($w:-resolution) + $($w:-from)}]] set ($w:uniteRotation) [expr {$($w:-start) - $angleDeg}] # # la liste des couleurs contient autant d'éléments que de valeurs possibles # prises par le widget set nb [expr {int(($($w:-to) - $($w:-from)) / $($w:-resolution) +1)}] set ($w:chfnDegrade) [::transx::rgbs $nb $($w:-chfnGColor1) $($w:-chfnGColor2)] set ($w:dispDegrade) [::transx::rgbs $nb $($w:-dispGColor1) $($w:-dispGColor2)] set ($w:indice) [expr {int( ($($w:-value) - $($w:-from)) / $($w:-resolution) )}] } proc ::vHF::actualiseRepere {w} { variable {} variable pi $w.cv delete repere set angle [::vHF::value2angle $w $($w:-value)] set lcos [expr {cos($angle*$pi/180-$pi/2)}] set lsin [expr {sin($angle*$pi/180-$pi/2)}] $w.cv create line \ [expr {$($w:centrex)+$($w:rayonpptCercle)*$lcos}]\ [expr {$($w:centrey)+$($w:rayonpptCercle)*$lsin}]\ [expr {$($w:centrex)+$($w:rayonptCercle)*$lcos}]\ [expr {$($w:centrey)+$($w:rayonptCercle)*$lsin}]\ -width $($w:-width) -fill $($w:-repColor) -tags repere if {$($w:-chfnGradient) eq 1} { $w.cv itemconfigure gdCercle -fill [lindex $($w:chfnDegrade) $($w:indice)] } if {$($w:-disp) eq 1} { set nb [format $($w:-format) $($w:-value)] if {$($w:-dispGradient) eq 1} { $w.cv itemconfigure valeur -text $nb -fill [lindex $($w:dispDegrade) $($w:indice)] } else { $w.cv itemconfigure valeur -text $nb -fill $($w:-dispColor) } } else { $w.cv itemconfigure valeur -text "" } update } proc ::vHF::constructionBouton {w} { variable {} variable pi set ($w:centrex) [expr {.5*$($w:-diam)}] set ($w:centrey) $($w:centrex) # $w.cv delete all # $w.cv configure -width $($w:-diam) -height $($w:-diam) $w.cv create oval \ 1 1 \ [expr {$($w:-diam)-1}] [expr {$($w:-diam)-1}] \ -fill $($w:-chfnColor) -width 2 -outline $($w:-fg) -tags gdCercle if {$($w:-chfnLines) eq 1} { for {set r 0} {$r<360} {incr r [expr {360/$($w:-chfnLNb)}]} { $w.cv create line \ $($w:centrex) $($w:centrey) \ [expr {$($w:centrex)*(1+cos($r*$pi/180))}] \ [expr {$($w:centrey)*(1+sin($r*$pi/180))}] \ -width $($w:-chfnLWidth) -fill $($w:-fg) -tags rayon } } $w.cv create oval \ $($w:-chfn) $($w:-chfn) \ $($w:diametreptCercle) $($w:diametreptCercle) \ -fill $($w:-fg) -width 1 -outline $($w:-fg) -tags ptCercle # $w.cv create text $($w:centrex) $($w:centrey) \ -tags valeur -fill white } ################################################################################################ ################################################################################################ ### Following namespace from international wiki page : 'Gradients Color Transitions' ### http://wiki.tcl.tk/9079 ### ### author : Rohan Pall ### date : 09/06/03 namespace eval transx { proc rgbs {n c1 c2} { # Color intensities are from 0 to 65535, 2 byte colors. foreach {r1 g1 b1} [winfo rgb . $c1] break foreach {r2 g2 b2} [winfo rgb . $c2] break #puts "c1: $r1 $g1 $b1" #puts "c2: $r2 $g2 $b2" # Normalize intensities to 0 to 255, 1 byte colors. foreach el {r1 g1 b1 r2 g2 b2} { set $el [expr {[set $el] * 255 / 65535}].0 } #puts "c1: $r1 $g1 $b1" #puts "c2: $r2 $g2 $b2" if {$n == 1} { set r_step 0.0 ; set g_step 0.0 ; set b_step 0.0 } else { set r_step [expr {($r2-$r1) / ($n-1)}] set g_step [expr {($g2-$g1) / ($n-1)}] set b_step [expr {($b2-$b1) / ($n-1)}] } #puts "$r_step $g_step $b_step" set steps {} for {set i 0} {$i < $n} {incr i} { set r [expr {int($r_step * $i + $r1)}] set g [expr {int($g_step * $i + $g1)}] set b [expr {int($b_step * $i + $b1)}] #puts "$r $g $b" lappend steps [format "#%.2X%.2X%.2X" $r $g $b] } return $steps } }
Exemples d'utilisation
Certains exemples utilisent les extensions pixane et shape pour fournir une interface circulaire. Pour l'exemple, mon fichier volumeHF.tcl se situe dans le répertoire VolumeHF avec le fichier pkgIndex.tcl suivant :
package ifneeded vHF 1.2.1 [list source [file join $dir volumeHF-1.2.1.tcl]]
Exemple 1
### contrôle du volume Master de la carte son via 'amixer' (linux) ### #### les paquets requis package require Tk package require pixane package require shape package require vHF 1.2.1 # namespace import vHF::* #### dimension du bouton 30x30... enfin à peu près ;) set dim 30 ## wm overrideredirect . 1 wm geometry . -0-0 ## création du masque pour la transparence set itk [image create photo] set ipx [pixane create -tkphoto $itk] pixane resize $ipx $dim $dim pixane blank $ipx pixane oval $ipx [expr {$dim/2}] [expr {$dim/2}] [expr {$dim/2 - 2}] ## utilisation du masque proc rafraichir {} { shape set . photo $::itk } bind . <Configure> [list rafraichir] #### Le volume ## on change la valeur du volume proc changeSon {} { exec amixer set Master $::niveauMaster } ## on récupère la valeur du volume ## régulièrement (si jamais c'est changé par un autre programme) proc recupNiveauMaster {} { set out [exec amixer get Master] regexp -line {Mono: Playback ([\d]+)} $out -> nv set ::niveauMaster $nv after 500 recupNiveauMaster } #### notre widget !! volumeHF .c -diam $dim -chfn 4 -length 2 \ -disp 1 -format %.0f -dispColor red -chfnGradient 1 \ -chfnLines 0 -variable niveauMaster -from 0 -to 39 \ -dispGradient 1 -fg black -activefg black pack .c ## le début de la liaison avec le volume recupNiveauMaster ## le binding bind .c <4> [list changeSon] bind .c <5> [list changeSon] bind . <3> [list destroy .]
Exemple 2
package require Tk package require vHF 1.2.1 namespace import vHF::* proc recalcule {w} { update set l [winfo width $w] set h [winfo height $w] set dim [expr {min($l,$h)}] $w configure -diam $dim } volumeHF .v bind .v <Configure> [list recalcule .v] pack .v -fill both -expand 1
Exemple 3
### réglage du gamma de l'écran sous X11 ### package require Tk package require vHF 1.2.1 namespace import vHF::* proc setGammaRGB {c} { set nv [set ::$c] if {$::link eq 1} { set option -gamma set ::red $nv set ::green $nv set ::blue $nv } else { set option -[string index $c 0]gamma } exec xgamma -q $option $nv } set red 1 set green 1 set blue 1 set i -1 set optionsG {-from .1 -to 10 -resolution .1 -diam 30 -length 4\ -chfnLines 0 -chfn 1 -repColor black} foreach v { red green blue } { volumeHF .$v -fg $v -variable $v \ {*}$optionsG grid .$v -row 0 -column [incr i] bind .$v <4> [list setGammaRGB $v] bind .$v <5> [list setGammaRGB $v] } set link 1 ttk::checkbutton .cb -text liaison -variable link grid .cb -row 1 -columnspan 3 -sticky news bind all <3> exit
Exemple 4
package require Tk package require vHF 1.2.1 namespace import vHF::* volumeHF .c -variable nb -to 1 -resolution .01 -format %.2f volumeHF .d -variable nb -to 1 -resolution .1 -format %.1f volumeHF .e -variable nb -to 1 -resolution 1 -format %.0f ttk::scale .s -variable nb pack .c .d .e .s