Rohan Pall, made on Sept 24, 2003
More
MDI!
Blatantly copied from
GPS's fantastic
Internal Movable Windows, with the addition of a resize corner. Wow! ;P
Stu 2008-10-25 Changed cursor from "size_nw_se" (Windows only) to "sizing" (all platforms).
#######
# The MDI uses the following globals: qx,qy,nx,ny
#######
proc resize_start {w x y} {
global qx qy
set qx $x
set qy $y
#puts "start: $qx $qy"
}
proc resize_do {w x y} {
global qx qy
set dqx [expr {$x-$qx}]
set dqy [expr {$y-$qy}]
set cur_w [winfo width $w]
set cur_h [winfo height $w]
set new_w [expr {$cur_w+$dqx}]
set new_h [expr {$cur_h+$dqy}]
#puts "do: x:$x y:$y qx:$qx qy:$qy (dqx:$dqx dqy:$dqy) $cur_w $cur_h => $new_w $new_h"
# Only resize the window if its bigger than the allowed minimum size.
if {$new_w >= 60} {place $w -width $new_w}
if {$new_h >= 50} {place $w -height $new_h}
}
proc move_start {w} {
global nx ny
set nx [winfo pointerx .]
set ny [winfo pointery .]
raise $w
}
proc move_do {w} {
global nx ny
set x [winfo pointerx .]
set y [winfo pointery .]
set dx [expr {$x-$nx}]
set dy [expr {$y-$ny}]
array set p [place info $w]
set px [expr {$p(-x)+$dx}]
set py [expr {$p(-y)+$dy}]
place $w -x $px -y $py
set nx $x
set ny $y
}
proc make_win {w txt} {
frame $w -bd 0
pack [frame $w.titlebar -bg gold -relief raised -cursor fleur] -side bottom -fill x
pack [label $w.titlebar.resize -text o -bg darkred -relief flat -bd 0 \
-cursor sizing] -side right -anchor s
pack [label $w.titlebar.title -font {{Lucida Console} 8} -bg gold -fg navy -text $w -anchor w] -side left
pack [frame $w.c -padx 2 -pady 2 -bg gold] -side top -fill both -expand 1
pack [text $w.c.t -width 20 -height 3] -fill both -expand 1
$w.c.t insert end $txt
bind $w.titlebar <1> [list move_start $w]
bind $w.titlebar <B1-Motion> [list move_do $w]
bind $w.titlebar <3> [list lower $w]
bind $w.titlebar.title <1> [list move_start $w]
bind $w.titlebar.title <B1-Motion> [list move_do $w]
bind $w.titlebar.resize <1> [list resize_start $w %x %y]
bind $w.titlebar.resize <B1-Motion> [list resize_do $w %x %y]
return $w
}
. conf -width 600 -height 400 -bg black
pack propagate . 0
place [make_win .w1 "Hello World"] -x 10 -y 40
place [make_win .w2 "Hello Person"] -x 300 -y 50