ulis, 2006-11-01. Un package rapidement hacké pour faire un panneau coulissant.
Rapidement hacké, rapidement hacké... Serait pas un peu vantard ? Et grossement buggé d'ailleurs. Bref, une deuxième version avec son lot de nouveautés : - adaptation automatique au changement de couleur du parent - animation à l'ouverture et la fermeture - offset automatique pour les opérations create et coords
ulis 2007-03-26. v 2.0.1 : correction d'un bug.
Pourquoi
Parce que ça manquait dans Tk.
Comment
Un RoundedPane pour le fond, un autre pour le titre et un RoundButton pour ouvrir et fermer.
Utilisation
# ==================================== # options : # # - toutes celles du RoundedPane # avec # - -bsize : le diamètre du bouton # - -font : la police du titre # - -height : la hauteur, en pixels # - -tbg, -tbackground : la couleur de fond du titre # - -tfg, -tforeground : la couleur du titre # - -theight : la hauteur du titre # - -title : le texte du titre # - -trelief : le relief du titre # - -width : la larguer, en pixels # ------------------------------------ # opérations : # # - toutes celles du RoundedPane # avec # - open : ouverture en grand # - close : montre juste le titre # ====================================
Configuration
Installation
Utilisation
package require SlippingPanel
Package SlippingPanel
if {[info exists ::slippingpanel::version]} { return } namespace eval ::slippingpanel \ { # #################################### # # A(Slipping)Panel package # variable version 2.0.0 # # 2006 (C), ulis (mailto:ulis.net(@)wanadoo.fr) # NOL Licence # # ==================================== # options : # # - toutes celles du RoundedPane sauf -bg, -background # plus # - -bsize : le diamètre du bouton # - -font : la police du titre # - -height : la hauteur, en pixels # - -pbg, -pbackground : la couleur de fond du panneau # - -tbg, -tbackground : la couleur de fond du titre # - -tfg, -tforeground : la couleur du titre # - -theight : la hauteur du titre # - -title : le texte du titre # - -trelief : le relief du titre # - -width : la largeur, en pixels # ------------------------------------ # opérations : # # - toutes celles du RoundedPane # plus # - open : ouverture en grand # - close : montre juste le titre # ==================================== # v 2.0.0 # refresh automatique # animation à l'ouverture et la fermeture # offset automatique pour les opérations create et coords # v 2.0.1 # rajout d'une parenthèse manquante dans config # #################################### # ========================== # # package # # ========================== package require Tk 8.4 package require RoundedPane 2.0 package require RoundButton 2.0 package provide SlippingPanel $version # ==================== # # entry point # # ==================== namespace export slippingpanel # ==================== # # global variables # # ==================== variable {} array set {} \ { :-bsize 16 :-font {Arial -12 bold} :-height 100 :-pbg #e0f0ff :-relief flat :-tbg #c0d0ff :-tfg navy :-theight 22 :-title "" :-trelief flat :-width 200 } # ==================== # # splittingpanel proc # # ==================== proc slippingpanel {w args} \ { variable {} set code [catch \ { variable {} # init options foreach option [array names {} :*] \ { set (${w}$option) $($option) } # splitting panel set width $(:-width) set w1 [expr {$width - 2}] set h1 $(:-theight) set height [expr {$h1 + 4}] set w2 [expr {$width / 2}] set h2 [expr {2 + $h1 / 2}] set w3 [expr {$width - $(:-bsize) - 4}] set h3 [expr {$h1 / 2}] set ($w:oheight) $(:-height) set ($w:cheight) $height frame $w set pw [winfo parent $w] $w config -bg [$pw cget -bg] roundedpane $w.rp -width $width -height $height -bg $(:-pbg) \ -relief $(:-relief) -bd 0 -highlightt 0 roundedpane $w.rp.title -width $w1 -height $h1 -bg $(:-tbg) \ -relief $(:-trelief) -bd 0 -highlightt 0 $w.rp create window $w2 $h2 -window $w.rp.title -tags window $w.rp.title create text 20 $h3 -anchor w -text $(:-title) \ -font $(:-font) -fill $(:-tfg) -tags text roundbutton $w.rp.title.button -size $(:-bsize) -image down \ -script [list ::slippingpanel::control $w] $w.rp.title create window $w3 $h3 -window $w.rp.title.button \ -tags button # showing widgets grid $w.rp # reference rename $w ::slippingpanel::_$w interp alias {} ::$w {} ::slippingpanel::dispatch $w # binding refresh rename $pw ::slippingpanel::_p$w proc ::$pw {args} [list eval ::slippingpanel::refresh $w \$args] # options if {$args != ""} { eval ::slippingpanel::config $w $args } # return ref set w } res] if {$code == 1} \ { set map [list roundedpane slippingpanel roundbutton slippingpanel] set res [string map $map $res] } return -code $code $res } # ==================== # # dispatch proc # # ==================== proc dispatch {w {cmd ""} args} \ { variable {} set code [catch \ { if {$cmd == ""} \ { error "missing slippingpanel operation" } switch -glob -- $cmd \ { cge* { eval ::slippingpanel::cget $w $args } coo* { eval ::slippingpanel::move $w coords $args } cre* { eval ::slippingpanel::move $w create $args } clo* { eval ::slippingpanel::closePanel $w $args } con* { eval ::slippingpanel::config $w $args } ope* { eval ::slippingpanel::openPanel $w $args } default { eval $w.rp $cmd $args } } } res] if {$code == 1} \ { set map [list roundedpane slippingpanel roundbutton slippingpanel] set res [string map $map $res] } return -code $code $res } # ==================== # # cget proc # # ==================== proc cget {w args} \ { variable {} if {[llength $args] != 1} \ { error "use is: \$w cget -option" } switch -glob -- $args \ { -bg - -bac* { ::slippingpanel::_$w cget -bg } -bsi* { $w.rp.title.button cget -size } -fon* { $w.rp.title itemcget text -font } -hei* { set ($w:-height) } -pbg - -pba* { $w.rp cget -bg } -tbg - -tba* { $w.rp.title cget -bg } -tfg - -tfo* { $w.rp.title itemcget text -fill } -the* { $w.rp.title cget -height } -tit* { $w.rp.title itemcget text -text } -tre* { $w.rp.title cget -relief } -wid* { set ($w:-width) } default { $w.rp cget $args } } } # ==================== # # config proc # # ==================== proc config {w args} \ { variable {} if {[llength $args] % 2 != 0} \ { error "use is: \$w config ?-option value?..." } set sflag 0 foreach {option value} $args \ { switch -glob -- $option \ { -bsi* { set ($w:-bsize) $value; set sflag 1 } -fon* { $w.rp.title itemconf text -font $value } -hei* { set ($w:-height) $value; set sflag 1 } -bg - -bac* - -pbg - -pba* { $w.rp config -bg $value } -tbg - -tba* { $w.rp.title config -bg $value } -tfg - -tfo* { $w.rp.title itemconf text -fill $value } -the* { set ($w:-theight) $value; set sflag 1 } -tit* { $w.rp.title itemconf text -text $value } -tre* { $w.rp.title config -relief $value } -wid* { set ($w:-width) $value; set sflag 1 } default { $w.rp config $option $value } } } if {$sflag} { ::slippingpanel::resize $w } } # ==================== # # open proc # # ==================== proc openPanel {w args} \ { variable {} if {[llength $args] != 0} \ { error "use is: \$w open" } if {[$w.rp.title.button cget -image] == "down"} \ { $w.rp.title.button config -image up set minh $($w:cheight) set maxh $($w:oheight) set dh [expr {($maxh - $minh) / 10.0}] set h [expr {$minh + $dh}] after 10 ::slippingpanel::_opening $w 10 $h $dh $maxh } } proc _opening {w dt h dh mh} \ { $w.rp config -height $h set h [expr {$h + $dh}] if {$h <= $mh} \ { after $dt ::slippingpanel::_opening $w $dt $h $dh $mh } } # ==================== # # close proc # # ==================== proc closePanel {w args} \ { variable {} if {[llength $args] != 0} \ { error "use is: \$w close" } if {[$w.rp.title.button cget -image] == "up"} \ { $w.rp.title.button config -image down set minh $($w:cheight) set maxh $($w:oheight) set dh [expr {($maxh - $minh) / 10.0}] set h [expr {$maxh - $dh}] after 10 ::slippingpanel::_closing $w 10 $h $dh $minh } } proc _closing {w dt h dh mh} \ { $w.rp config -height $h set h [expr {$h - $dh}] if {$h >= $mh} \ { after $dt ::slippingpanel::_closing $w $dt $h $dh $mh } } # ==================== # # move proc # # ==================== proc move {w oper args} \ { variable {} set count [llength $args] set dy $($w:cheight) if {$count == 2 || [string match -* [lindex $args 2]]} \ { # coords list set lcoords [lindex $args 1] set max [llength $lcoords] for {set i 1} {$i < $max} {incr i 2} \ { set y [winfo fpixels $w [lindex $lcoords $i]] set y [expr {$y + $dy}] lset lcoords $i $y } lset args 1 $lcoords } \ else \ { # individual coords for {set i 1} {$i < $count} {incr i 2} \ { if {[string match -* [lindex $args $i]]} { break } set iy [expr {$i + 1}] set y [winfo fpixels $w [lindex $args $iy]] set y [expr {$y + $dy}] lset args $iy $y } } eval $w.rp $oper $args } # ==================== # # refresh proc # # ==================== proc refresh {w largs} \ { variable {} set code [catch \ { set res [uplevel 1 ::slippingpanel::_p$w $largs] set cmd [lindex $largs 0] if {[string match $cmd* configure]} \ { foreach {key value} [lrange $largs 1 end] \ { switch -glob -- $key \ { -bg - -bac* \ { set bg [[winfo parent $w] cget -bg] ::slippingpanel::_$w config -bg $bg } } } } set res } res] return -code $code $res } # ==================== # # control proc # # ==================== proc control {w} \ { variable {} switch [$w.rp.title.button cget -image] \ { down { openPanel $w } up { closePanel $w } } } # ==================== # # resize proc # # ==================== proc resize {w} \ { variable {} set width $($w:-width) set height $($w:-height) set w1 [expr {$width - 2}] set h1 $(:-theight) set w2 [expr {$width / 2}] set h2 [expr {2 + $h1 / 2}] set w3 [expr {$width - $(:-bsize) - 4}] set h3 [expr {$h1 / 2}] set ($w:oheight) $height set ($w:cheight) [expr {$h1 + 4}] if {[$w.rp.title.button cget -image] == "down"} \ { set height $($w:cheight) } $w.rp config -width $width -height $height $w.rp coords window $w2 $h2 $w.rp.title config -width $w1 -height $h1 $w.rp.title coords text 20 $h3 $w.rp.title coords window $w3 $h3 $w.rp.title.button config -size $(:-bsize) } } namespace import ::slippingpanel::slippingpanel
Script de description pkgIndex.tcl
package ifneeded SlippingPanel 2.0 [list source [file join $dir SlippingPanel.tcl]]
Demo
# test package require SlippingPanel . config -padx 10 -pady 10 -bg red foreach i {1 2} \ { slippingpanel .sp$i -width 200 -height 100 -title "Titre du panneau $i" grid .sp$i -pady 5 } .sp2 config -tbg beige -tfg orange -pbg orange .sp2 create rectangle 0 0 30 24 -fill white -tags rect .sp2 create text 15 5 -anchor nw -text ici -font {Arial -12} after 2000 . config -bg gold after 3000 .sp1 open after 4000 .sp1 close after 4500 .sp2 open after 5000 .sp2 coords rect 10 0 40 24
Exercice
Dans le cadre de Tk avancé voici un exercice délicat : trouver le bug.
Il s'agit de faire un megawidget qui utilise lui-même un megawidget (vi, comme SlippingPanel).
L'exemple ci-dessous crée un premier megawidget (w1) autour d'un widget canvas. Il n'y a aucune nouvelle fonctionnalité. Juste d'aller moins vite.
Le deuxième megawidget (w2) fait la même chose, mais utilise w1 au lieu du canvas (Ah canvas, quand tu nous tiens !).
Ya un bug ! Trouvez-le. (merci de ne pas mettre la réponse ici sinon c'est plus un exercice)
# ================== # Ya un bug! # ================== package require Tk # nop megawidget around a canvas widget namespace eval ::w1 \ { namespace export w1 proc w1 {w args} \ { canvas $w rename $w ::w1::_$w interp alias {} ::$w {} ::w1::dispatch $w eval config $w $args return $w } proc dispatch {w cmd args} \ { switch -glob -- $cmd \ { con* { eval ::w1::config $w $args } default { eval ::w1::_$w $cmd $args } } } proc config {w args} \ { eval ::w1::_$w config $args } } namespace import ::w1::w1 # test it w1 .w1 -width 100 -height 100 -bg gold grid .w1 update after 1000 # nop megawidget around a w1 megawidget namespace eval ::w2 \ { namespace export w2 proc w2 {w args} \ { w1 $w rename $w ::w2::_$w interp alias {} ::$w {} ::w2::dispatch $w eval config $w $args return $w } proc dispatch {w cmd args} \ { switch -glob -- $cmd \ { con* { eval ::w2::config $w $args } default { eval ::w2::_$w $cmd $args } } } proc config {w args} \ { eval ::w2::_$w config $args } } namespace import ::w2::w2 # test it w2 .w2 -width 100 -height 100 -bg red grid .w2
Voir Aussi
(le désert)
Discussion
ulis Personne ne sait comment on prend un brevet ? Et combien ça coûte ?
Kroc Moi je sais, mais c'est cher et de toute façon inutile ;)
ulis Même pour faire la nique à (mi-)Gros Soft ?
Catégorie Paquet | Catégorie Interface utilisateur