a(Round)Button

 

ulis, 2006-11-01. Un package rapidement hacké pour faire un bouton rond.

v2 pour que le bouton tienne compte automatiquement de la couleur de fond du parent.


Pourquoi

Pour pouvoir faire des panneaux coulissants tout jolis.


Comment

Bin avec le canvas ! Un oval pour le rond, des arcs pour les bords, une image au milieu.


Utilisation

  # ====================================
  #  options :
  #
  # -bd, -borderwidth : largeur de la bordure
  # -img, -image : image du bouton
  #   valeurs prédéfinies : up, down, left, right
  # -relief : relief du bouton
  #   ridge est équivalent à raised, groove à sunken
  # -script : script à activer
  # -size : diamètre du bouton, en pixels
  # ------------------------------------
  #  opérations :
  #
  # cget : retourne la valeur d'une option
  # configure : modifie les options du bouton
  # invoke : active le script
  # ====================================

Configuration

Installation

Utilisation

  package require RoundButton

Package

  if {[info exists ::roundbutton::version]} { return }

  namespace eval ::roundbutton \
  {
  # ####################################
  #
  #   A(Round)Button package
  #
  variable version 2.0.0
  #
  # 2006 (C), ulis (mailto:ulis.net(@)wanadoo.fr)
  # NOL Licence
  #
  # ====================================
  #  options :
  #
  # -bd, -borderwidth : largeur de la bordure
  # -img, -image : image du bouton
  #   valeurs prédéfinies : up, down, left, right
  # -relief : relief du bouton
  #   ridge est équivalent à raised, groove à sunken
  # -script : script à activer
  # -size : diamètre du bouton, en pixels
  # ------------------------------------
  #  opérations :
  #
  # cget : retourne la valeur d'une option
  # configure : modifie les options du bouton
  # invoke : active le script
  # ====================================
  # v 2.0
  #   refresh automatique
  # ####################################

    # ==========================
    #
    # package
    #
    # ==========================

    package require Tk 8.4

    package provide RoundButton $version

    # ====================
    #
    # entry point
    #
    # ====================

    namespace export roundbutton

    # ====================
    #
    #   global variables
    #
    # ====================

    variable {}
    array set {} \
    {
      :-bd          1
      :-highlightt  0
      :-relief      raised
      :-script      ""
      :-size        16
      data:up \
      {
        {#000 #000 #000 #000 #000}
        {#000 #000 #666 #000 #000}
        {#000 #666 #666 #666 #000}
        {#666 #666 #666 #666 #666}
        {#000 #000 #000 #000 #000}
      }
       data:down \
      {
        {#000 #000 #000 #000 #000}
        {#666 #666 #666 #666 #666}
        {#000 #666 #666 #666 #000}
        {#000 #000 #666 #000 #000}
        {#000 #000 #000 #000 #000}
      }
      data:left \
      {
        {#000 #000 #000 #666 #000}
        {#000 #000 #666 #666 #000}
        {#000 #666 #666 #666 #000}
        {#000 #000 #666 #666 #000}
        {#000 #000 #000 #666 #000}
      }
      data:right \
      {
        {#000 #666 #000 #000 #000}
        {#000 #666 #666 #000 #000}
        {#000 #666 #666 #666 #000}
        {#000 #666 #666 #000 #000}
        {#000 #666 #000 #000 #000}
      }
    }
    set (:-img) [image create photo]
    set w ._roundbutton_
    entry $w
    set (color:light) [$w cget -background]
    set (color:dark)  [$w cget -disabledforeground]
    destroy $w
    button $w
    set (:-bg) [$w cget -bg]
    destroy $w
    unset w
    foreach img {up down left right} \
    {
      set (img:$img) [image create photo]
      $(img:$img) put $(data:$img)
      for {set i 0} {$i < 5} {incr i} \
      {
        for {set j 0} {$j < 5} {incr j} \
        {
          if {[lindex $(data:$img) $i $j] == "#000"} \
          { $(img:$img) transparency set $j $i 1 }
        }
      }
    }

      # ====================
      #
      #   roundbutton proc
      #
      # ====================

    proc roundbutton {w args} \
    {
      variable {}
      set code [catch \
      {
        # init options
        foreach option [array names {} :*] \
        { set (${w}$option) $($option) }
        # create round button
        set bd $(:-bd)
        set bd2 [expr {$bd / 2}]
        if {$bd2 == 0} { set bd2 1 }
        set size $(:-size)
        set radius [expr {$size / 2}]
        set size [expr {$radius * 2}]
        set size2 [expr {$size + 2 * $bd}]
        set size3 [expr {$size + $bd}]
        set center [expr {$radius + $bd}]
        set (:size) $size
        canvas $w -width $size2 -height $size2 \
          -bd 0 -highlightt 0
        $w config -bg [[winfo parent $w] cget -bg]
        $w create oval $bd2 $bd2 $size3 $size3 \
          -tags bg -outline "" -fill $(:-bg)
        $w create arc $bd2 $bd2 $size3 $size3 -width $bd \
          -tags nw -start 45 -extent 180 \
          -style arc -outline $(color:light)
        $w create arc $bd $bd $size3 $size3 -width $bd \
          -tags se -start 45 -extent -180 \
          -style arc -outline $(color:dark)
        $w create image $center $center -tags img
        # bindings
        set ($w:resizing) 0
        bind $w <Configure> [list ::roundbutton::resize $w]
        $w bind all <ButtonPress-1> [list ::roundbutton::lowerButton $w]
        $w bind all <ButtonRelease-1> [list ::roundbutton::raiseButton $w %x %y]
        # binding refresh
        set pw [winfo parent $w]
        rename $pw ::roundbutton::_p$w
        proc ::$pw {args} [list eval ::roundbutton::refresh $w \$args]
        # reference
        rename $w ::roundbutton::_$w
        interp alias {} ::$w {} ::roundbutton::dispatch $w
        # options
        if {$args != ""} { eval ::roundbutton::config $w $args }
        # return ref
        set w
      } res]
      return -code $code $res
    }

      # ====================
      #
      #   dispatch proc
      #
      # ====================

    proc dispatch {w {cmd ""} args} \
    {
      variable {}
      set code [catch \
      {
        if {$cmd == ""} \
        { error "missing roundbutton operation" }
        switch -glob -- $cmd \
        {
          cge*    { eval ::roundbutton::cget $w $args }
          con*    { eval ::roundbutton::config $w $args }
          inv*    { eval ::roundbutton::invoke $w $args }
          default { eval ::roundbutton::_$w $cmd $args }
        }
      } 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 \
      {
        -bd           -
        -bor*         { set ($w:-bd) }
        -img          -
        -ima*         { set ($w:-img) }
        -rel*         { set ($w:-relief) }
        -scr*         { set ($w:-script) }
        -siz*         { set ($w:-size) }
        default       \
        { error "unknown roundbutton option '$args'" }
      }
    }

      # ====================
      #
      #   config proc
      #
      # ====================

    proc config {w args} \
    {
      variable {}
      if {[llength $args] % 2 != 0} \
      { error "use is: \$w config ?-option value?..." }
      set _w ::roundbutton::_$w
      set ($w:resizing) 1
      set sflag 0
      foreach {option value} $args \
      {
        switch -glob -- $option \
        {
          -bd           -
          -bor*         { set ($w:-bd) $value; set sflag 1 }
          -bg           -
          -bac*         \
          {
            set ($w:-bg) $value
            $_w config bg -fill $value
          }
          -img          -
          -ima*         \
          {
            set ($w:-img) $value
            switch -exact -- $value \
            {
              up      { set value $(img:up) }
              down    { set value $(img:down) }
              left    { set value $(img:left) }
              right   { set value $(img:right) }
            }
            $_w itemconf img -image $value
          }
          -rel*         \
          {
            switch -glob -- $value \
            {
              fla*    { set value flat }
              gro*    { set value groove }
              rai*    { set value raised }
              rid*    { set value ridge }
              sol*    { set value solid }
              sun*    { set value sunken }
              default \
              { error "unknown roundbutton relief '$value'" }
            }
            set ($w:-relief) $value
            relief $w
          }
          -scr*         { set ($w:-script) $value }
          -siz*         \
          {
            set ($w:-size) $value
            $_w config -width $value -height $value
            set sflag 1
          }
          default       \
          { error "unknown roundbutton option '$option'" }
        }
      }
      set ($w:resizing) 0
      if {$sflag} { ::roundbutton::resize $w }
    }

      # ====================
      #
      #   invoke proc
      #
      # ====================

    proc invoke {w args} \
    {
      variable {}
      if {[llength $args] != 0} \
      { error "use is: \$w invoke" }
      set _w ::roundbutton::_$w
      eval $($w:-script)
    }

      # ====================
      #
      #   refresh proc
      #
      # ====================

    proc refresh {w largs} \
    {
      variable {}
      set code [catch \
      {
        set res [uplevel 1 ::roundbutton::_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]
                ::roundbutton::_$w config -bg $bg
              }
            }
          }
        }
        set res
      } res]
      return -code $code $res
    }

      # ====================
      #
      #   relief proc
      #
      # ====================

    proc relief {w} \
    {
      variable {}
      set pbg [[winfo parent $w] cget -bg]
      switch -exact $($w:-relief) \
      {
        flat   \
        {
          set bg $($w:-bg)
          set dark $bg
          set light $bg
        }
        groove  -
        sunken  \
        {
          set dark $(color:dark)
          set light $(color:light)
        }
        raised  -
        ridge   \
        {
          set light $(color:dark)
          set dark $(color:light)
        }
        solid   \
        {
          set light black
          set dark black
        }
      }
      set _w ::roundedpane::_$w
      $_w itemconf nw -outline $dark
      $_w itemconf se -outline $light
    }

      # ====================
      #
      #   resize proc
      #
      # ====================

    proc resize {w} \
    {
      variable {}
      if {$($w:resizing)} { return }
      set ($w:resizing) 1
      set _w ::roundbutton::_$w
      set size2 [winfo width $w]
      set height [winfo height $w]
      if {$height < $size2} { set size2 $height }
      # resize round button
      set bd $(:-bd)
      set size [expr {$size2 - 2 * $bd}]
      set bd2 [expr {$bd / 2}]
      if {$bd2 == 0} { set bd2 1 }
      set radius [expr {$size / 2}]
      set size [expr {$radius * 2}]
      set size2 [expr {$size + 2 * $bd}]
      set size3 [expr {$size + $bd}]
      set center [expr {$radius + $bd}]
      set (:size) $size
      $_w coords bg $bd2 $bd2 $size3 $size3
      $_w coords nw $bd2 $bd2 $size3 $size3
      $_w itemconf nw -width $bd
      $_w coords se $bd $bd $size3 $size3
      $_w itemconf se -width $bd
      $_w coords img $center $center
      set ($w:resizing) 0
    }

      # ====================
      #
      #   events procs
      #
      # ====================

    proc lowerButton {w} \
    {
      variable {}
      $w itemconfig nw -outline $(color:dark)
      $w itemconfig se -outline $(color:light)
      $w move img 1 1
    }

    proc raiseButton {w x y} \
    {
      variable {}
      $w itemconfig nw -outline $(color:light)
      $w itemconfig se -outline $(color:dark)
      $w move img -1 -1
      onButton $w $x $y
    }

    proc onButton {w x y} \
    {
      variable {}
      set size $($w:-size)
      if {$x >= 0 && $x <= $size \
       && $y >= 0 && $y <= $size} \
      { after 0 ::roundbutton::invoke $w }
    }

  }
  namespace import ::roundbutton::roundbutton

Script de description pkgIndex.tcl

  package ifneeded RoundButton 2.0 [list source [file join $dir RoundButton.tcl]]

La démo

  # exemple d'utilisation
  package require RoundButton

  wm title . RoundButton
  . config -padx 10 -pady 10 -bg gold
  set script [list grid]
  foreach button {up down left right} \
  {
    roundbutton .$button -size 20 -script exit -image $button
    lappend script .$button
  }
  eval $script -padx 12
  after 2000 . config -bg green

Voir Aussi

J'en ai trouvé nulle part !

Faut peut-être que je le brevette ?


Discussion

ulis Combien coûte un brevet ?

Miko Cher, je pense... d'autre part, le bouton rond (et "mappé"?) existe avec TkZinc. [1]

ulis Je serais étonné que Tkzink définisse d'autres widgets que lui-même. Dans un exemple peut-être ?

Miko Cette image [2] est extraite de la démo. Les boutons sont évidemment sur un "canvas" Zingué, mais ils sont ronds...

ulis et ils ont jolis !

Bon, bin je renonce à mon brevet. N'importe comment Kroc veut pas.


Catégorie Paquet | Catégorie Interface utilisateur