//***Screenshot 
//#ref(LightningTcl.gif,nolink)
 # A little pallet window
 # written by reddog
 
 package require Tk 8.4
 package require Itcl
 namespace import itcl::*
 
 class pallet {
	 private variable objlist {}
	 private variable root {}
	 private variable parent {}
	 private common color
	 set color(base) #888888
	 set color(tab1) #888888
	 set color(tab2) white
	 set color(text) black
	 # For Drag and Drop
	 private variable source {}
 
	 constructor {parentw x y} {
		 set parent $parentw
		 set root [getToplevel $parent $this]
 
		 toplevel $root -takefocus 1
		 wm geometry  $root +$x+$y
		 wm attribute $root -toolwindow 1 -topmost 1
 
		 canvas $root.c -background $color(base) -width 200 -height 20
		 pack $root.c -side top -padx 0 -fill x -expand yes
	 }
 
	 # Tools
	 #=====================================================
	 # return Toplevel Name
	 private method getToplevel {parentw obj} {
		 set top $parentw
		 if {$top eq {.}} {
			 set top {}
		 }
		 return $top.[string map {{::} {}} $obj]
	 }
 	
	 # return Toplevel Widget in X,Y
	 private method getPalletInPos {x y} {
		 set tlist [wm stackorder $parent]
		 set sel {}
		 set max -1
		 foreach obj [find objects -class pallet] {
			 set top [getToplevel $parent $obj]
			 if {[isEnter $top $x $y]} {
				 set order [lsearch $tlist $top]
				 if {$order > $max} {
					 set sel $obj
					 set max $order
				 }
			 }
		 }
		 return $sel
	 }
 	
	 private method isEnter {top x y} {
		 if {$top eq {}} {return 0}
		 regexp -- {(.+)x(.+)\+(.+)\+(.+)} [winfo geometry $top] m w h rx ry
		 if {$x < $rx || $y < $ry} {
			 return 0
		 } elseif {$rx+$w < $x || $ry+$h < $y} {
			 return 0
		 }
		 return 1
	 }
 
	 # Page Operation
	 #=====================================================
	 # update Tab(Title)
	 private method appendTab {obj prev} {
		 set title [$obj getTitle]
		 set bbox [$root.c bbox [lindex [$root.c find withtag $prev] 0]]
		 if {$bbox ne {}} {
			 set leftm [expr [lindex $bbox 2] - 4]
		 } else {
			 set leftm 8
		 }
 
		 set textid [$root.c create text $leftm 21 -anchor sw \
			 -text $title -font {{} 8 } -tag [list $obj text]]
		 set bbox [$root.c bbox $obj]
		 set bottom	[lindex $bbox 1]
		 set left	[lindex $bbox 0]
		 set top		[lindex $bbox 3]
		 set right	[lindex $bbox 2]
		 $root.c create polygon \
			 [expr $left-4]   $top\
			 [expr $left-4]   [expr $bottom-2] \
			 [expr $right+2]  [expr $bottom-2] \
			 [expr $right+15] $top \
			 -fill $color(tab1) -outline black -tag [list $obj tab]
		 $root.c bind $obj <ButtonPress-1>   "$this press $obj"
		 $root.c bind $obj <ButtonRelease-1> "$this release $obj %X %Y"
		 $root.c raise $textid
	 }
 
	 private method updateTab {} {
		 $root.c delete all
		 set prev {}
		 foreach obj $objlist {
			 appendTab $obj $prev
			 set prev $obj
		 }
	 }
 	
	 # append/remove Page(Frame)
	 private method appendPage {obj} {
		 set fname [frame $root.$obj]
		 $obj createUI $fname
	 }
 
	 private method removePage {obj} {
		 destroy $root.$obj
		 set idx [lsearch $objlist $obj]
		 set objlist [lreplace $objlist $idx $idx]
	 }
 	
	 # append/remove Object
	 public method append {obj} {
		 lappend objlist $obj
		 appendPage $obj
		 updateTab
		 select $obj
	 }
 
	 public method remove {obj} {
		 removePage $obj
		 if {[llength $objlist]==0} {
			 delete object $this
		 } else {
			 updateTab
			 select [lindex $objlist 0]
		 }
	 }
 
	 # Select a Page and raise it.
	 public method select {obj} {
		 # select a tab
		 $root.c itemconfigure tab -fill $color(tab1)
		 foreach item [$root.c find withtag tab] {
			 if {[lsearch [$root.c itemcget $item -tags] $obj] != -1} {
				 $root.c itemconfigure $item -fill $color(tab2)
				 break
			 }
		 }
		 $root.c raise $obj
 
		 # select a page
		 foreach w [pack slaves $root] {
			 if {$w != "$root.c"} {
				 pack forget $w
			 }
		 }
		 wm title $root [$obj getTitle]
		 pack $root.$obj
	 }
 	
	 # Mouse Event
	 #=====================================================
	 public method press {obj} {
		 set source $this
	 }
 
	 public method release {obj x y} {
		 set target [getPalletInPos $x $y]
		 set source_top [getToplevel $parent $source]
		 set target_top [getToplevel $parent $target]
 
		 if {$source ne $target && [isEnter $target_top $x $y]} {
			 # Move
			 $target append $obj
			 $source remove $obj
		 } elseif {[isEnter $source_top $x $y]} {
			 # Select
			 select $obj
		 } else {
			 # Create New
			 $source remove $obj
			 set tmp [uplevel 1 "pallet #auto $parent [expr $x-50] [expr $y-10]"]
			 $tmp append $obj
		 }
		 set source {}
	 }
 
	 destructor {
		 destroy $root
	 }
 }
 
 class WidgetSetCreator {
	 public variable title
 
	 constructor {t} {
		 set title $t
	 }
 
	 method setTitle {title} {
		 set title $title
	 }
 
	 method getTitle {} {
		 return $title
	 }
 }
 
 class Test1 {
	 inherit WidgetSetCreator
	 constructor {title} {
		 ::WidgetSetCreator::constructor $title
	 } {}
 	
	 method createUI {root} {
		 entry $root.e -textvariable ::info(name)
		 button $root.b -text Show -command \
			 "tk_messageBox -message \"Title = $\{[scope title]\} \nName = \$::info(name)\""
		 pack $root.e $root.b
	 }
 
	 destructor {}
 }
 
 class Test2 {
	 inherit WidgetSetCreator
	 constructor {title} {
		 ::WidgetSetCreator::constructor $title
	 } {}
 	
	 method createUI {root} {
		 radiobutton $root.r1 -text Apple  -value Apple  -variable ::info(select)
		 radiobutton $root.r2 -text Orange -value Orange -variable ::info(select)
		 radiobutton $root.r3 -text Banana -value Banana -variable ::info(select)
		 button $root.b -text Select -command \
			 "tk_messageBox -message \"Title = $\{[scope title]\} \nSelect = \$::info(select)\""
		 pack $root.r1 $root.r2 $root.r3 $root.b
	 }
 
	 destructor {}
 }
 
 array set info {
	 name {}
	 select Apple
 }
 
 button .b -text Exit -command {exit}
 pack .b -fill x -pady 3
 
 pallet mypl . 10 10
 mypl append [Test1 myfc1 Hello]
 mypl append [Test2 myfc2 Radio]
 

#ref(pallet.gif,nolink)

***コメントをどーぞ [#nb108632]
#comment

----
[[CategoryTclTk]]
HTML convert time: 0.005 sec.