blob: 8a16a119e452e034fea62a53c8165db5ad7b26a9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}
## valid.tcl
##
## This demos shows the use of the validation mechanism of the table
## and uses the table's cache (no -command or -variable)
##
## jeff at hobbs org
source [file join [file dirname [info script]] loadtable.tcl]
array set table {
rows 10
cols 10
table .table
}
proc colorize num {
if {$num>0 && $num%2} { return colored }
}
proc fill_headers {w {r 10} {c 10}} {
for {set i 1} {$i < $r} {incr i} {
$w set $i,0 "$i"
}
for {set j 1} {$j < $c} {incr j} {
if {$j%3==1} {
$w set 0,$j AlphaNum
} elseif {$j%2==1} {
$w set 0,$j Alpha
} elseif {$j} {
$w set 0,$j Real
}
}
}
proc validate {c val} {
if {$c%3==1} {
## Alphanum
set expr {^[A-Za-z0-9 ]*$}
} elseif {$c%2==1} {
## Alpha
set expr {^[A-Za-z ]*$}
} elseif {$c} {
## Real
set expr {^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$}
}
if {[regexp $expr $val]} {
return 1
} else {
bell
return 0
}
}
label .example -text "TkTable v1 Validated Table Example"
set t $table(table)
table $t \
-rows $table(rows) \
-cols $table(cols) \
-cache 1 \
-titlerows 1 \
-titlecols 1 \
-yscrollcommand { .tsy set } \
-xscrollcommand { .tsx set } \
-width 5 -height 5 \
-coltagcommand colorize \
-flashmode on \
-selectmode extended \
-colstretch unset \
-rowstretch unset \
-validate yes \
-vcmd {if {![%W tag includes title %C]} { validate %c %S } }
fill_headers $t
$t tag config colored -bg lightblue
$t tag config title -fg red
$t width 0 3
scrollbar .tsy -command [list $t yview]
scrollbar .tsx -command [list $t xview] -orient horizontal
button .exit -text "Exit" -command {exit}
grid .example - -sticky ew
grid $t .tsy -sticky news
grid .tsx -sticky ew
grid .exit - -sticky ew
grid columnconfig . 0 -weight 1
grid rowconfig . 1 -weight 1
puts [list Table is $table(table)]
|
