a(Slipping)Panel

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

• Récupérer le package SlippingPanel et le script de description pkgIndex.tcl ci-dessous.
• Les installer dans un sous-répertoire SlippingPanel du répertoire lib de Tcl.

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)

• Le panneau arrondi : a(Rounded)Pane
• Le bouton rond : a(Round)Button

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

Mis à jour le 26 mars 2007 à 08:23 CEST par Maurice Ulis  -  Editer a(Slipping)Panel
Rechercher - Dernières modifications - 4 Références - Le Wiki tcl francophone - Aide