Posted to tcl by jeremy_c at Fri Sep 14 15:55:35 GMT 2007view raw
- package require Tk
- package require tile
- package require snit
- snit::widget idlabelmenubutton {
- hulltype ttk::frame
- delegate option -width to mb
- delegate option -direction to mb
- option -textvariable {}
- option -listvariable {}
- option -idvariable {}
- variable ids -array {}
- variable item_id -1
- constructor {args} {
- install mb using ttk::menubutton $win.mb
- $self configurelist $args
- $win.mb configure -textvariable $options(-textvariable)
- pack $win.mb -padx 0 -pady 0 -expand 1 -fill x
- install mopts using menu $win.menu
- $win.mb configure -menu $win.menu
- upvar #0 $options(-idvariable) idvar
- upvar #0 $options(-listvariable) listvar
- trace add variable idvar write [list $self id_updated]
- trace add variable listvar write [list $self list_updated]
- $self list_updated
- $self id_updated
- }
- method add {id label} {
- $win.menu add command -label $label -command [list $self update $id $label]
- set ids($id) $label
- }
- method clear {} {
- catch {$win.menu delete 0 end}
- }
- method item_id {} {
- return $item_id
- }
- method update {new_id new_text} {
- $win.mb configure -text $new_text
- set item_id $new_id
- upvar #0 $options(-idvariable) idvar
- upvar #0 $options(-textvariable) textvar
- catch {set idvar $new_id}
- catch {set textvar $new_text}
- }
- method id_updated {{var {}} {args {}}} {
- upvar #0 $options(-idvariable) idvar
- upvar #0 $options(-textvariable) textvar
- if {[catch {
- if {$idvar == {}} {
- return
- }}]} {
- return
- }
- if {[catch {set textvar $ids($idvar)}]} {
- return -code 1 "$idvar not found in idlabelmenubutton"
- }
- }
- method list_updated {{var {}} {args {}}} {
- upvar #0 $options(-listvariable) listvar
- if {$listvar == {}} {
- return
- }
- $win.mb configure -text ""
- $self clear
- foreach {id label} $listvar {
- $self add $id $label
- }
- $self id_updated
- }
- delegate method * to mb
- }
- set greetingid 1
- set greeting ""
- set greetings {1 Hello 3 "What's Up" 2 Goodbye}
- ttk::frame .f
- pack .f -expand 1 -fill both
- ttk::label .f.greeting_l -text "Greeting:"
- idlabelmenubutton .f.greeting -listvariable greetings -width 10
- ttk::button .f.greet -text "Greet" -command {
- tk_messageBox -message "$greeting, World!"
- }
- grid .f.greeting_l .f.greeting -padx 3 -pady 3
- grid .f.greet -column 1 -padx 3 -pady 3 -sticky w
- wm title . "Greeter"
- raise .