# 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]
//***Screenshot
//#ref(LightningTcl.gif,nolink)
#ref(pallet.gif,nolink)
***コメントをどーぞ [#nb108632]
#comment
----
[[CategoryTclTk]]
HTML convert time: 0.002 sec.