a(Rounded)Pane

 

ulis, 2006-10-31. Un package rapidement hacké pour afficher un panneau arrondi.

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


Pourquoi

Parce que c'est à la mode.


Comment

Avec des images en coin. Et un binding sur <Configure>.


Utilisation

  # ====================================
  #  options :
  #
  # - toutes les options du canvas, mais
  # + -bd, -borderwidth toujours à 1
  # + -highlightthickness toujours à 0
  #
  # ------------------------------------
  #  opérations :
  #
  # - toutes les opérations du canvas
  # ====================================

Configuration

Installation

Utilisation

  package require RoundedPane

Package RoundedPane

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

  namespace eval ::roundedpane \
  {
  # ####################################
  #
  #   A(Rounded)Pane package
  #
  variable version 2.0.0
  #
  # 2006 (C), ulis (mailto:ulis.net(@)wanadoo.fr)
  # NOL Licence
  #
  # ====================================
  #  options :
  #
  # - toutes les options du canvas, mais
  # + -bd, -borderwidth toujours à 1
  # + -highlightthickness toujours à 0
  #
  # ------------------------------------
  #  opérations :
  #
  # - toutes les opérations du canvas
  # ====================================
  # v 2.0.0
  #   refresh automatique
  # ####################################

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

    package require Tk 8.4

    package provide RoundedPane $version

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

    namespace export roundedpane

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

    variable {}
    array set {} \
    {
      :-bd          1
      :-height      100
      :-highlightt  0
      :-relief      flat
      :-width       100

      data:nw \
      {
        {#222 #222 #222 #222 #111}
        {#222 #222 #111 #111 #000}
        {#222 #111 #000 #000 #000}
        {#222 #111 #000 #000 #000}
        {#111 #000 #000 #000 #000}
      }
       data:ne \
      {
        {#111 #222 #222 #222 #222}
        {#000 #111 #111 #222 #222}
        {#000 #000 #000 #111 #222}
        {#000 #000 #000 #111 #222}
        {#000 #000 #000 #000 #111}
      }
      data:sw \
      {
        {#111 #000 #000 #000 #000}
        {#222 #111 #000 #000 #000}
        {#222 #111 #000 #000 #000}
        {#222 #222 #111 #111 #000}
        {#222 #222 #222 #222 #111}
      }
      data:se \
      {
        {#000 #000 #000 #000 #111}
        {#000 #000 #000 #111 #222}
        {#000 #000 #000 #111 #222}
        {#000 #111 #111 #222 #222}
        {#111 #222 #222 #222 #222}
      }
    }
    set w ._roundedpane_
    entry $w
    set (color:light) [$w cget -background]
    set (color:dark) [$w cget -disabledforeground]
    destroy $w

      # ====================
      #
      #   roundedpane proc
      #
      # ====================

    proc roundedpane {w args} \
    {
      variable {}
      set code [catch \
      {
        # init options
        foreach option [array names {} :*] \
        { set (${w}$option) $($option) }
        # create images
        foreach corner {nw ne se sw} \
        { set ($w:image:$corner) [image create photo] }
        # create rounded pane
        set width $(:-width)
        set height $(:-height)
        canvas $w -width $width -height $height \
          -bd 0 -highlightt 0
        set ($w:-bg) [::roundedpane::color [$w cget -bg]]
        set w1 [expr {$width - 1}]
        set h1 [expr {$height - 1}]
        $w create line 0 0 $w1 0 -fill $(color:dark) \
          -tags [list $w $w:n]
        $w create line 0 0 0 $h1 -fill $(color:dark) \
          -tags [list $w $w:w]
        $w create line 0 $h1 $w1 $h1 -fill $(color:light) \
          -tags [list $w $w:s]
        $w create line $w1 0 $w1 $h1 -fill $(color:light) \
          -tags [list $w $w:e]
        $w create image 0 0 -anchor nw -image $($w:image:nw) \
          -tags [list $w $w:nw]
        $w create image 0 $height -anchor sw -image $($w:image:sw) \
          -tags [list $w $w:sw]
        $w create image $width 0 -anchor ne -image $($w:image:ne) \
          -tags [list $w $w:ne]
        $w create image $width $height -anchor se -image $($w:image:se) \
          -tags [list $w $w:se]
        # bindings
        set ($w:resizing) 0
        bind $w <Configure> [list ::roundedpane::resize $w]
        # binding refresh
        set pw [winfo parent $w]
        rename $pw ::roundedpane::_p$w
        proc ::$pw {args} [list eval ::roundedpane::refresh $w \$args]
        # reference
        rename $w ::roundedpane::_$w
        interp alias {} ::$w {} ::roundedpane::dispatch $w
        # options
        if {$args != ""} { eval ::roundedpane::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 roundedpane operation" }
        switch -glob -- $cmd \
        {
          cge*    { eval ::roundedpane::cget $w $args }
          con*    { eval ::roundedpane::config $w $args }
          default { eval ::roundedpane::_$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) }
        -highlightt*  { set ($w:-hlt) }
        default       { ::roundedpane::_$w cget $args }
      }
    }

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

    proc config {w args} \
    {
      variable {}
      if {[llength $args] % 2 != 0} \
      { error "use is: \$w config ?-option value?..." }
      set options [list]
      foreach {option value} $args \
      {
        switch -glob -- $option \
        {
          -bd           -
          -bor*         { set ($w:-bd) 1 }
          -bg           -
          -bac*         \
          {
            set ($w:-bg) [::roundedpane::color $value]
            border $w
            lappend options $option $value
          }
          -highlightt*  { set ($w:-hlt) 0 }
          -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 roundedpane relief '$value'" }
            }
            set ($w:-relief) $value
            border $w
          }
          default       { lappend options $option $value }
        }
      }
      if {$options != ""} { eval ::roundedpane::_$w config $options }
    }

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

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

      # ====================
      #
      #   border proc
      #
      # ====================

    proc border {w {pbg ""}} \
    {
      variable {}
      if {$pbg == ""} \
      { set pbg [color [[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 $w:n -fill $dark
      $_w itemconf $w:w -fill $dark
      $_w itemconf $w:s -fill $light
      $_w itemconf $w:e -fill $light
      set map [list #111 $dark #222 $pbg]
      foreach corner {nw sw} \
      {
        set data($corner) [string map $map $(data:$corner)]
      }
      set map [list #111 $light #222 $pbg]
      foreach corner {ne se} \
      {
        set data($corner) [string map $map $(data:$corner)]
      }
      foreach corner {nw ne se sw} \
      {
        $($w:image:$corner) put $data($corner)
        for {set i 0} {$i < 5} {incr i} \
        {
          for {set j 0} {$j < 5} {incr j} \
          {
            if {[lindex $(data:$corner) $i $j] == "#000"} \
            { $($w:image:$corner) transparency set $j $i 1 }
          }
        }
      }
    }

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

    proc resize {w} \
    {
      variable {}
      if {$($w:resizing)} { return }
      set ($w:resizing) 1
      set _w ::roundedpane::_$w
      set width [winfo width $w]
      set height [winfo height $w]
      set w1 [expr {$width - 1}]
      set h1 [expr {$height - 1}]
      $_w coords $w:n 0 0 $w1 0
      $_w coords $w:w 0 0 0 $h1
      $_w coords $w:s 0 $h1 $w1 $h1
      $_w coords $w:e $w1 0 $w1 $h1
      $_w coords $w:nw 0 0
      $_w coords $w:sw 0 $height
      $_w coords $w:ne $width 0
      $_w coords $w:se $width $height
      set ($w:resizing) 0
    }

      # ====================
      #
      #   color proc
      #
      # ====================

    proc color {color} \
    {
      foreach {r g b} [winfo rgb . $color] break
      foreach c {r g b} \
      {
        set v [set $c]
        set $c [expr {$v & 255}]
      }
      return [format #%2.2x%2.2x%2.2x $r $g $b]
    }

      # ====================
      #
      #   initial colors
      #
      # ====================

    foreach color {light dark} \
    { set (color:$color) [color $(color:$color)] }
  }
  namespace import ::roundedpane::roundedpane

Script de description pkgIndex.tcl

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

La démo

  # ####################
  #
  #       demo
  #
  # ####################

    package require RoundedPane

    # config root window
    . config -padx 10 -pady 10 -bg gold
    # create rounded pane
    roundedpane .rp -bg gray -width 200 -height 100 -relief groove
    grid .rp
    # populate pane
    roundedpane .rp.rp -width 150 -height 50 -relief raised -bg gold
    .rp create window 25 25 -anchor nw -window .rp.rp
    .rp create text 100 10 -text dedans
    .rp.rp create text 75 22 -text dessus

Voir Aussi

Heu... Ya ça sous Tcl ?


Discussion

ulis Bin si, c'est un canvas. Arrondi.


Catégorie Paquet | Catégorie Interface utilisateur