#By George Peter Staplin
#This is public-domain software. You may use it however you
#want; with or without giving me credit.
#When I get some spare time I will add error handling to the
#config instance command, and the initial flags.
namespace eval ctable {
variable firstX
}
proc ctable::drawSlider:setInitialPosition x {
variable firstX
set firstX $x
}
proc ctable::dragSlider {sep frame1 x} {
variable firstX
set win [winfo parent $sep]
set diff [expr {$x - $firstX}]
set xUnits [expr {1.0 / [winfo width $win]}]
set haveSecondFrame 0
set frame2 [expr {$frame1 + 1}]
array set arF0 [place info $win.f$frame1]
array set arS0 [place info $win.sep$frame1]
if {[winfo exists $win.f$frame2] == 1} {
array set arF1 [place info $win.f$frame2]
set haveSecondFrame 1
}
set xdiff [expr {$diff * $xUnits}]
place $win.f$frame1 -relwidth [expr {$arF0(-relwidth) + $xdiff}]
place $win.sep$frame1 -relx [expr {$arS0(-relx) + $xdiff}]
if {$haveSecondFrame == 1} {
place $win.f$frame2 -relx [expr {$arF1(-relx) + $xdiff}]
place $win.f$frame2 -relwidth [expr {$arF1(-relwidth) - $xdiff}]
}
set firstX $x
return
}
proc ctable {win args} {
frame $win
set cmdArgs(-columns) 5
set cmdArgs(-rows) 5
array set cmdArgs $args
set relxPortion [expr {1.0 / $cmdArgs(-columns)}]
set relx 0
for {set i 0} {$i < $cmdArgs(-columns)} {incr i} {
place [frame $win.f$i] -relx $relx -relwidth $relxPortion
pack [entry $win.f$i.e0 -bg gray70 -relief raised] \
-side top -fill x -padx 6 -ipadx 4
for {set rowIndex 1} {$rowIndex <= $cmdArgs(-rows)} {incr rowIndex} {
pack [entry $win.f$i.e$rowIndex] -side top -fill x -padx 6
}
set relx [expr {$relx + $relxPortion}]
#puts $relx
}
set relx $relxPortion
for {set sepIndex 0} {$sepIndex < ($cmdArgs(-columns) - 1)} {incr sepIndex} {
place [frame $win.sep$sepIndex -bg gray70 -width 8 \
-cursor sb_h_double_arrow -relief raised -bd 1] -relx $relx \
-x -4 -relheight 1.0
set relx [expr {$relx + $relxPortion}]
bind $win.sep$sepIndex <Button-1> "ctable::drawSlider:setInitialPosition %X"
bind $win.sep$sepIndex <B1-Motion> "ctable::dragSlider %W $sepIndex %X"
}
set mapCmd {}
if {[info exists cmdArgs(-height)] == 1} {
append mapCmd "%W configure -height $cmdArgs(-height); "
} else {
append mapCmd "%W configure -height \[winfo height %W.f0\]; "
}
if {[info exists cmdArgs(-width)] == 1} {
append mapCmd "%W configure -width $cmdArgs(-width)"
} else {
append mapCmd "%W configure -width \[expr {$cmdArgs(-columns) * 100}\]"
}
update idletasks
bind $win <Map> $mapCmd
rename $win _ctable$win
proc $win {cmd args} {
set self [lindex [info level 0] 0]
set actWin _ctable$self
if {$cmd == "config"} {
set cmd configure
}
switch -- $cmd {
configure {
eval $actWin config $args
}
insert {
if {[llength $args] != 3} {
return -code error {invalid number of arguments: use .instance insert column row data}
}
set column [lindex $args 0]
set row [lindex $args 1]
set data [list [lindex $args 2]]
eval $self.f$column.e$row insert 0 $data
}
}
}
return $win
}Test Code
#!/usr/local/bin/wish8.3
source ./ctable.tcl
proc main {} {
pack [ctable .t -columns 4 -rows 5] -side top -fill both
#column 0 row 0
.t insert 0 0 {First Name}
.t insert 1 0 {Last Name}
.t insert 2 0 Job
.t insert 3 0 {Primary Key}
set i 1
foreach fname {Angelica Henry Richard John Jane} {
.t insert 0 $i $fname
incr i
}
set i 1
foreach lname {Smith Fresco Scorso Doe Doe} {
.t insert 1 $i $lname
incr i
}
set i 1
foreach job {Marketing Sales Projections {Information Systems} \
{Sanitation Engineer}} {
.t insert 2 $i $job
incr i
}
for {set i 1} {$i <= 5} {incr i} {
.t insert 3 $i $i
}
}
main
(Image link broken on Sep. 15, 2011)