Posted to tcl by jeremy_c at Fri Sep 14 15:55:35 GMT 2007view raw

  1. package require Tk
  2. package require tile
  3.  
  4. package require snit
  5.  
  6. snit::widget idlabelmenubutton {
  7. hulltype ttk::frame
  8.  
  9. delegate option -width to mb
  10. delegate option -direction to mb
  11.  
  12. option -textvariable {}
  13. option -listvariable {}
  14. option -idvariable {}
  15.  
  16. variable ids -array {}
  17. variable item_id -1
  18.  
  19. constructor {args} {
  20. install mb using ttk::menubutton $win.mb
  21. $self configurelist $args
  22. $win.mb configure -textvariable $options(-textvariable)
  23. pack $win.mb -padx 0 -pady 0 -expand 1 -fill x
  24.  
  25. install mopts using menu $win.menu
  26. $win.mb configure -menu $win.menu
  27.  
  28. upvar #0 $options(-idvariable) idvar
  29. upvar #0 $options(-listvariable) listvar
  30. trace add variable idvar write [list $self id_updated]
  31. trace add variable listvar write [list $self list_updated]
  32.  
  33. $self list_updated
  34. $self id_updated
  35. }
  36.  
  37. method add {id label} {
  38. $win.menu add command -label $label -command [list $self update $id $label]
  39. set ids($id) $label
  40. }
  41.  
  42. method clear {} {
  43. catch {$win.menu delete 0 end}
  44. }
  45.  
  46. method item_id {} {
  47. return $item_id
  48. }
  49.  
  50. method update {new_id new_text} {
  51. $win.mb configure -text $new_text
  52. set item_id $new_id
  53.  
  54. upvar #0 $options(-idvariable) idvar
  55. upvar #0 $options(-textvariable) textvar
  56. catch {set idvar $new_id}
  57. catch {set textvar $new_text}
  58. }
  59.  
  60. method id_updated {{var {}} {args {}}} {
  61. upvar #0 $options(-idvariable) idvar
  62. upvar #0 $options(-textvariable) textvar
  63. if {[catch {
  64. if {$idvar == {}} {
  65. return
  66. }}]} {
  67. return
  68. }
  69.  
  70. if {[catch {set textvar $ids($idvar)}]} {
  71. return -code 1 "$idvar not found in idlabelmenubutton"
  72. }
  73. }
  74.  
  75. method list_updated {{var {}} {args {}}} {
  76. upvar #0 $options(-listvariable) listvar
  77. if {$listvar == {}} {
  78. return
  79. }
  80. $win.mb configure -text ""
  81. $self clear
  82. foreach {id label} $listvar {
  83. $self add $id $label
  84. }
  85. $self id_updated
  86. }
  87.  
  88. delegate method * to mb
  89. }
  90.  
  91. set greetingid 1
  92. set greeting ""
  93. set greetings {1 Hello 3 "What's Up" 2 Goodbye}
  94.  
  95. ttk::frame .f
  96. pack .f -expand 1 -fill both
  97.  
  98. ttk::label .f.greeting_l -text "Greeting:"
  99. idlabelmenubutton .f.greeting -listvariable greetings -width 10
  100. ttk::button .f.greet -text "Greet" -command {
  101. tk_messageBox -message "$greeting, World!"
  102. }
  103.  
  104. grid .f.greeting_l .f.greeting -padx 3 -pady 3
  105. grid .f.greet -column 1 -padx 3 -pady 3 -sticky w
  106.  
  107. wm title . "Greeter"
  108. raise .