diff options
Diffstat (limited to 'src/bin/pgaccess/lib/forms.tcl')
| -rw-r--r-- | src/bin/pgaccess/lib/forms.tcl | 1263 |
1 files changed, 1263 insertions, 0 deletions
diff --git a/src/bin/pgaccess/lib/forms.tcl b/src/bin/pgaccess/lib/forms.tcl new file mode 100644 index 00000000000..631c3537c72 --- /dev/null +++ b/src/bin/pgaccess/lib/forms.tcl @@ -0,0 +1,1263 @@ +namespace eval Forms { + +proc {new} {} { +global PgAcVar + Window show .pgaw:FormDesign:menu + tkwait visibility .pgaw:FormDesign:menu + Window show .pgaw:FormDesign:toolbar + tkwait visibility .pgaw:FormDesign:toolbar + Window show .pgaw:FormDesign:attributes + tkwait visibility .pgaw:FormDesign:attributes + Window show .pgaw:FormDesign:draft + design:init +} + + +proc {open} {formname} { + forms:load $formname run + design:run +} + +proc {design} {formname} { + forms:load $formname design +} + + +proc {design:change_coords} {} { +global PgAcVar + set PgAcVar(fdvar,dirty) 1 + set i $PgAcVar(fdvar,attributeFrame) + if {$i == 0} { + # it's the form + set errmsg "" + if {[catch {wm geometry .pgaw:FormDesign:draft $PgAcVar(fdvar,c_width)x$PgAcVar(fdvar,c_height)+$PgAcVar(fdvar,c_left)+$PgAcVar(fdvar,c_top)} errmsg] != 0} { + showError $errmsg + } + return + } + set c [list $PgAcVar(fdvar,c_left) $PgAcVar(fdvar,c_top) [expr $PgAcVar(fdvar,c_left)+$PgAcVar(fdvar,c_width)] [expr $PgAcVar(fdvar,c_top)+$PgAcVar(fdvar,c_height)]] + set PgAcVar(fdobj,$i,coord) $c + .pgaw:FormDesign:draft.c delete o$i + design:draw_object $i + design:draw_hookers $i +} + + +proc {design:delete_object} {} { +global PgAcVar + set i $PgAcVar(fdvar,moveitemobj) + .pgaw:FormDesign:draft.c delete o$i + .pgaw:FormDesign:draft.c delete hook + set j [lsearch $PgAcVar(fdvar,objlist) $i] + set PgAcVar(fdvar,objlist) [lreplace $PgAcVar(fdvar,objlist) $j $j] + set PgAcVar(fdvar,dirty) 1 +} + + +proc {design:draw_hook} {x y} { + .pgaw:FormDesign:draft.c create rectangle [expr $x-2] [expr $y-2] [expr $x+2] [expr $y+2] -fill black -tags hook +} + + +proc {design:draw_hookers} {i} { +global PgAcVar + foreach {x1 y1 x2 y2} $PgAcVar(fdobj,$i,coord) {} + .pgaw:FormDesign:draft.c delete hook + design:draw_hook $x1 $y1 + design:draw_hook $x1 $y2 + design:draw_hook $x2 $y1 + design:draw_hook $x2 $y2 +} + + +proc {design:draw_grid} {} { + for {set i 0} {$i<100} {incr i} { + .pgaw:FormDesign:draft.c create line 0 [expr {$i*6}] 1000 [expr {$i*6}] -fill #afafaf -tags grid + .pgaw:FormDesign:draft.c create line [expr {$i*6}] 0 [expr {$i*6}] 1000 -fill #afafaf -tags grid + } +} + + +proc {design:draw_object} {i} { +global PgAcVar +set c $PgAcVar(fdobj,$i,coord) +foreach {x1 y1 x2 y2} $c {} +.pgaw:FormDesign:draft.c delete o$i +set wfont $PgAcVar(fdobj,$i,font) +switch $wfont { + {} {set wfont $PgAcVar(pref,font_normal) ; set PgAcVar(fdobj,$i,font) normal} + normal {set wfont $PgAcVar(pref,font_normal)} + bold {set wfont $PgAcVar(pref,font_bold)} + italic {set wfont $PgAcVar(pref,font_italic)} + fixed {set wfont $PgAcVar(pref,font_fix)} +} +switch $PgAcVar(fdobj,$i,class) { + button { + design:draw_rectangle $x1 $y1 $x2 $y2 $PgAcVar(fdobj,$i,relief) $PgAcVar(fdobj,$i,bcolor) o$i + .pgaw:FormDesign:draft.c create text [expr ($x1+$x2)/2] [expr ($y1+$y2)/2] -fill $PgAcVar(fdobj,$i,fcolor) -text $PgAcVar(fdobj,$i,label) -font $wfont -tags o$i + } + text { + design:draw_rectangle $x1 $y1 $x2 $y2 $PgAcVar(fdobj,$i,relief) $PgAcVar(fdobj,$i,bcolor) o$i + } + entry { + design:draw_rectangle $x1 $y1 $x2 $y2 $PgAcVar(fdobj,$i,relief) $PgAcVar(fdobj,$i,bcolor) o$i + } + label { + set temp $PgAcVar(fdobj,$i,label) + if {$temp==""} {set temp "____"} + design:draw_rectangle $x1 $y1 $x2 $y2 $PgAcVar(fdobj,$i,relief) $PgAcVar(fdobj,$i,bcolor) o$i + .pgaw:FormDesign:draft.c create text [expr {$x1+1}] [expr {$y1+1}] -text $temp -fill $PgAcVar(fdobj,$i,fcolor) -font $wfont -anchor nw -tags o$i + } + checkbox { + design:draw_rectangle [expr $x1+2] [expr $y1+5] [expr $x1+12] [expr $y1+15] raised #a0a0a0 o$i + .pgaw:FormDesign:draft.c create text [expr $x1+20] [expr $y1+3] -text $PgAcVar(fdobj,$i,label) -anchor nw \ + -fill $PgAcVar(fdobj,$i,fcolor) -font $wfont -tags o$i + } + radio { + .pgaw:FormDesign:draft.c create oval [expr $x1+4] [expr $y1+5] [expr $x1+14] [expr $y1+15] -fill white -tags o$i + .pgaw:FormDesign:draft.c create text [expr $x1+24] [expr $y1+3] -text $PgAcVar(fdobj,$i,label) -anchor nw \ + -fill $PgAcVar(fdobj,$i,fcolor) -font $wfont -tags o$i + } + query { + .pgaw:FormDesign:draft.c create oval $x1 $y1 [expr $x1+20] [expr $y1+20] -fill white -tags o$i + .pgaw:FormDesign:draft.c create text [expr $x1+5] [expr $y1+4] -text Q -anchor nw -font $PgAcVar(pref,font_normal) -tags o$i + } + listbox { + design:draw_rectangle $x1 $y1 [expr $x2-12] $y2 sunken $PgAcVar(fdobj,$i,bcolor) o$i + design:draw_rectangle [expr $x2-11] $y1 $x2 $y2 sunken gray o$i + .pgaw:FormDesign:draft.c create line [expr $x2-5] $y1 $x2 [expr $y1+10] -fill #808080 -tags o$i + .pgaw:FormDesign:draft.c create line [expr $x2-10] [expr $y1+9] $x2 [expr $y1+9] -fill #808080 -tags o$i + .pgaw:FormDesign:draft.c create line [expr $x2-10] [expr $y1+9] [expr $x2-5] $y1 -fill white -tags o$i + .pgaw:FormDesign:draft.c create line [expr $x2-5] $y2 $x2 [expr $y2-10] -fill #808080 -tags o$i + .pgaw:FormDesign:draft.c create line [expr $x2-10] [expr $y2-9] $x2 [expr $y2-9] -fill white -tags o$i + .pgaw:FormDesign:draft.c create line [expr $x2-10] [expr $y2-9] [expr $x2-5] $y2 -fill white -tags o$i + } +} +.pgaw:FormDesign:draft.c raise hook +} + +proc {design:draw_rectangle} {x1 y1 x2 y2 relief color tag} { + if {$relief=="raised"} { + set c1 white + set c2 #606060 + } + if {$relief=="sunken"} { + set c1 #606060 + set c2 white + } + if {$relief=="ridge"} { + design:draw_rectangle $x1 $y1 $x2 $y2 raised none $tag + design:draw_rectangle [expr {$x1+1}] [expr {$y1+1}] [expr {$x2+1}] [expr {$y2+1}] sunken none $tag + design:draw_rectangle [expr {$x1+2}] [expr {$y1+2}] $x2 $y2 flat $color $tag + return + } + if {$relief=="groove"} { + design:draw_rectangle $x1 $y1 $x2 $y2 sunken none $tag + design:draw_rectangle [expr {$x1+1}] [expr {$y1+1}] [expr {$x2+1}] [expr {$y2+1}] raised none $tag + design:draw_rectangle [expr {$x1+2}] [expr {$y1+2}] $x2 $y2 flat $color $tag + return + } + if {$color != "none"} { + .pgaw:FormDesign:draft.c create rectangle $x1 $y1 $x2 $y2 -outline "" -fill $color -tags $tag + } + if {$relief=="flat"} { + return + } + .pgaw:FormDesign:draft.c create line $x1 $y1 $x2 $y1 -fill $c1 -tags $tag + .pgaw:FormDesign:draft.c create line $x1 $y1 $x1 $y2 -fill $c1 -tags $tag + .pgaw:FormDesign:draft.c create line $x1 $y2 $x2 $y2 -fill $c2 -tags $tag + .pgaw:FormDesign:draft.c create line $x2 $y1 $x2 [expr 1+$y2] -fill $c2 -tags $tag +} + + +proc {design:init} {} { +global PgAcVar + PgAcVar:clean fdvar,* + PgAcVar:clean fdobj,* + catch {.pgaw:FormDesign:draft.c delete all} + # design:draw_grid + set PgAcVar(fdobj,0,name) {f1} + set PgAcVar(fdobj,0,class) form + set PgAcVar(fdobj,0,command) {} + set PgAcVar(fdvar,formtitle) "New form" + set PgAcVar(fdvar,objnum) 0 + set PgAcVar(fdvar,objlist) {} + set PgAcVar(fdvar,oper) none + set PgAcVar(fdvar,tool) point + set PgAcVar(fdvar,resizable) 1 + set PgAcVar(fdvar,dirty) 0 +} + + +proc {design:item_click} {x y} { +global PgAcVar + set PgAcVar(fdvar,oper) none + set PgAcVar(fdvar,moveitemobj) {} + set il [.pgaw:FormDesign:draft.c find overlapping $x $y $x $y] + .pgaw:FormDesign:draft.c delete hook + if {[llength $il] == 0} { + design:show_attributes 0 + return + } + set tl [.pgaw:FormDesign:draft.c gettags [lindex $il 0]] + set i [lsearch -glob $tl o*] + if {$i == -1} return + set objnum [string range [lindex $tl $i] 1 end] + set PgAcVar(fdvar,moveitemobj) $objnum + set PgAcVar(fdvar,moveitemx) $x + set PgAcVar(fdvar,moveitemy) $y + set PgAcVar(fdvar,oper) move + design:show_attributes $objnum + design:draw_hookers $objnum +} + + +proc {forms:load} {name mode} { +global PgAcVar CurrentDB + design:init + set PgAcVar(fdvar,formtitle) $name + if {$mode=="design"} { + Window show .pgaw:FormDesign:draft + Window show .pgaw:FormDesign:menu + Window show .pgaw:FormDesign:attributes + Window show .pgaw:FormDesign:toolbar + } + set res [wpg_exec $CurrentDB "select * from pga_forms where formname='$PgAcVar(fdvar,formtitle)'"] + set info [lindex [pg_result $res -getTuple 0] 1] + pg_result $res -clear + set PgAcVar(fdobj,0,name) [lindex $info 0] + set PgAcVar(fdvar,objnum) [lindex $info 1] + # check for old format , prior to 0.97 that + # save here the objlist (deprecated) + set temp [lindex $info 2] + if {[lindex $temp 0] == "FS"} { + set PgAcVar(fdobj,0,command) [lindex $temp 1] + } else { + set PgAcVar(fdobj,0,command) {} + } + set PgAcVar(fdvar,objlist) {} + set PgAcVar(fdvar,geometry) [lindex $info 3] + set i 1 + foreach objinfo [lrange $info 4 end] { + lappend PgAcVar(fdvar,objlist) $i + set PgAcVar(fdobj,$i,class) [lindex $objinfo 0] + set PgAcVar(fdobj,$i,name) [lindex $objinfo 1] + set PgAcVar(fdobj,$i,coord) [lindex $objinfo 2] + set PgAcVar(fdobj,$i,command) [lindex $objinfo 3] + set PgAcVar(fdobj,$i,label) [lindex $objinfo 4] + set PgAcVar(fdobj,$i,variable) [lindex $objinfo 5] + design:setDefaultReliefAndColor $i + set PgAcVar(fdobj,$i,value) $PgAcVar(fdobj,$i,name) + if {[llength $objinfo] > 6 } { + set PgAcVar(fdobj,$i,value) [lindex $objinfo 6] + set PgAcVar(fdobj,$i,relief) [lindex $objinfo 7] + set PgAcVar(fdobj,$i,fcolor) [lindex $objinfo 8] + set PgAcVar(fdobj,$i,bcolor) [lindex $objinfo 9] + set PgAcVar(fdobj,$i,borderwidth) [lindex $objinfo 10] + set PgAcVar(fdobj,$i,font) [lindex $objinfo 11] + # for space saving purposes we have saved onbly the first letter + switch $PgAcVar(fdobj,$i,font) { + n {set PgAcVar(fdobj,$i,font) normal} + i {set PgAcVar(fdobj,$i,font) italic} + b {set PgAcVar(fdobj,$i,font) bold} + f {set PgAcVar(fdobj,$i,font) fixed} + } + } + if {$mode=="design"} {design:draw_object $i} + incr i + } + if {$mode=="design"} {wm geometry .pgaw:FormDesign:draft $PgAcVar(fdvar,geometry)} +} + + +proc {design:mouse_down} {x y} { +global PgAcVar + set x [expr 3*int($x/3)] + set y [expr 3*int($y/3)] + set PgAcVar(fdvar,xstart) $x + set PgAcVar(fdvar,ystart) $y + if {$PgAcVar(fdvar,tool)=="point"} { + design:item_click $x $y + return + } + set PgAcVar(fdvar,oper) draw +} + + +proc {design:mouse_move} {x y} { +global PgAcVar + #set PgAcVar(fdvar,msg) "x=$x y=$y" + set x [expr 3*int($x/3)] + set y [expr 3*int($y/3)] + set oper "" + catch {set oper $PgAcVar(fdvar,oper)} + if {$oper=="draw"} { + catch {.pgaw:FormDesign:draft.c delete curdraw} + .pgaw:FormDesign:draft.c create rectangle $PgAcVar(fdvar,xstart) $PgAcVar(fdvar,ystart) $x $y -tags curdraw + return + } + if {$oper=="move"} { + set dx [expr $x-$PgAcVar(fdvar,moveitemx)] + set dy [expr $y-$PgAcVar(fdvar,moveitemy)] + .pgaw:FormDesign:draft.c move o$PgAcVar(fdvar,moveitemobj) $dx $dy + .pgaw:FormDesign:draft.c move hook $dx $dy + set PgAcVar(fdvar,moveitemx) $x + set PgAcVar(fdvar,moveitemy) $y + set PgAcVar(fdvar,dirty) 1 + } +} + +proc {design:setDefaultReliefAndColor} {i} { +global PgAcVar + set PgAcVar(fdobj,$i,borderwidth) 1 + set PgAcVar(fdobj,$i,relief) flat + set PgAcVar(fdobj,$i,fcolor) {} + set PgAcVar(fdobj,$i,bcolor) {} + set PgAcVar(fdobj,$i,font) normal + switch $PgAcVar(fdobj,$i,class) { + button { + set PgAcVar(fdobj,$i,fcolor) #000000 + set PgAcVar(fdobj,$i,bcolor) #d9d9d9 + set PgAcVar(fdobj,$i,relief) raised + } + text { + set PgAcVar(fdobj,$i,fcolor) #000000 + set PgAcVar(fdobj,$i,bcolor) #fefefe + set PgAcVar(fdobj,$i,relief) sunken + } + entry { + set PgAcVar(fdobj,$i,fcolor) #000000 + set PgAcVar(fdobj,$i,bcolor) #fefefe + set PgAcVar(fdobj,$i,relief) sunken + } + label { + set PgAcVar(fdobj,$i,fcolor) #000000 + set PgAcVar(fdobj,$i,bcolor) #d9d9d9 + set PgAcVar(fdobj,$i,relief) flat + } + checkbox { + set PgAcVar(fdobj,$i,fcolor) #000000 + set PgAcVar(fdobj,$i,bcolor) #d9d9d9 + set PgAcVar(fdobj,$i,relief) flat + } + radio { + set PgAcVar(fdobj,$i,fcolor) #000000 + set PgAcVar(fdobj,$i,bcolor) #d9d9d9 + set PgAcVar(fdobj,$i,relief) flat + } + listbox { + set PgAcVar(fdobj,$i,fcolor) #000000 + set PgAcVar(fdobj,$i,bcolor) #fefefe + set PgAcVar(fdobj,$i,relief) sunken + } + } +} + +proc {design:mouse_up} {x y} { +global PgAcVar + set x [expr 3*int($x/3)] + set y [expr 3*int($y/3)] + if {$PgAcVar(fdvar,oper)=="move"} { + set PgAcVar(fdvar,moveitem) {} + set PgAcVar(fdvar,oper) none + set oc $PgAcVar(fdobj,$PgAcVar(fdvar,moveitemobj),coord) + set dx [expr $x - $PgAcVar(fdvar,xstart)] + set dy [expr $y - $PgAcVar(fdvar,ystart)] + set newcoord [list [expr $dx+[lindex $oc 0]] [expr $dy+[lindex $oc 1]] [expr $dx+[lindex $oc 2]] [expr $dy+[lindex $oc 3]]] + set PgAcVar(fdobj,$PgAcVar(fdvar,moveitemobj),coord) $newcoord + design:show_attributes $PgAcVar(fdvar,moveitemobj) + design:draw_hookers $PgAcVar(fdvar,moveitemobj) + return + } + if {$PgAcVar(fdvar,oper)!="draw"} return + set PgAcVar(fdvar,oper) none + .pgaw:FormDesign:draft.c delete curdraw + # Check for x2<x1 or y2<y1 + if {$x<$PgAcVar(fdvar,xstart)} {set temp $x ; set x $PgAcVar(fdvar,xstart) ; set PgAcVar(fdvar,xstart) $temp} + if {$y<$PgAcVar(fdvar,ystart)} {set temp $y ; set y $PgAcVar(fdvar,ystart) ; set PgAcVar(fdvar,ystart) $temp} + # Check for too small sizes + if {[expr $x-$PgAcVar(fdvar,xstart)]<20} {set x [expr $PgAcVar(fdvar,xstart)+20]} + if {[expr $y-$PgAcVar(fdvar,ystart)]<10} {set y [expr $PgAcVar(fdvar,ystart)+10]} + incr PgAcVar(fdvar,objnum) + set i $PgAcVar(fdvar,objnum) + lappend PgAcVar(fdvar,objlist) $i + + set PgAcVar(fdobj,$i,class) $PgAcVar(fdvar,tool) + set PgAcVar(fdobj,$i,coord) [list $PgAcVar(fdvar,xstart) $PgAcVar(fdvar,ystart) $x $y] + set PgAcVar(fdobj,$i,name) $PgAcVar(fdvar,tool)$i + set PgAcVar(fdobj,$i,label) $PgAcVar(fdvar,tool)$i + set PgAcVar(fdobj,$i,command) {} + set PgAcVar(fdobj,$i,variable) {} + set PgAcVar(fdobj,$i,value) {} + + design:setDefaultReliefAndColor $i + + design:draw_object $i + design:show_attributes $i + set PgAcVar(fdvar,moveitemobj) $i + design:draw_hookers $i + set PgAcVar(fdvar,tool) point + set PgAcVar(fdvar,dirty) 1 +} + + +proc {design:save} {name} { +global PgAcVar CurrentDB + if {[string length $PgAcVar(fdobj,0,name)]==0} { + tk_messageBox -title [intlmsg Warning] -message [intlmsg "Forms need an internal name, only literals, low case"] + return 0 + } + if {[string length $PgAcVar(fdvar,formtitle)]==0} { + tk_messageBox -title [intlmsg Warning] -message [intlmsg "Form must have a name"] + return 0 + } + set info [list $PgAcVar(fdobj,0,name) $PgAcVar(fdvar,objnum) [list FS $PgAcVar(fdobj,0,command)] [wm geometry .pgaw:FormDesign:draft]] + foreach i $PgAcVar(fdvar,objlist) { + set wfont $PgAcVar(fdobj,$i,font) + if {[lsearch {normal bold italic fixed} $wfont] != -1} { + set wfont [string range $wfont 0 0] + } + lappend info [list $PgAcVar(fdobj,$i,class) $PgAcVar(fdobj,$i,name) $PgAcVar(fdobj,$i,coord) $PgAcVar(fdobj,$i,command) $PgAcVar(fdobj,$i,label) $PgAcVar(fdobj,$i,variable) $PgAcVar(fdobj,$i,value) $PgAcVar(fdobj,$i,relief) $PgAcVar(fdobj,$i,fcolor) $PgAcVar(fdobj,$i,bcolor) $PgAcVar(fdobj,$i,borderwidth) $wfont] + } + sql_exec noquiet "delete from pga_forms where formname='$PgAcVar(fdvar,formtitle)'" + regsub -all "'" $info "''" info + sql_exec noquiet "insert into pga_forms values ('$PgAcVar(fdvar,formtitle)','$info')" + Mainlib::cmd_Forms + set PgAcVar(fdvar,dirty) 0 + return 1 +} + + +proc {design:set_name} {} { +global PgAcVar + set i $PgAcVar(fdvar,moveitemobj) + foreach k $PgAcVar(fdvar,objlist) { + if {($PgAcVar(fdobj,$k,name)==$PgAcVar(fdvar,c_name)) && ($i!=$k)} { + tk_messageBox -title [intlmsg Warning] -message [format [intlmsg "There is another object (a %s) with the same name.\nPlease change it!"] $PgAcVar(fdobj,$k,class)] + return + } + } + set PgAcVar(fdobj,$i,name) $PgAcVar(fdvar,c_name) + design:show_attributes $i + set PgAcVar(fdvar,dirty) 1 +} + + +proc {design:set_text} {} { +global PgAcVar + design:draw_object $PgAcVar(fdvar,moveitemobj) + set PgAcVar(fdvar,dirty) 1 +} + + +proc {design:createAttributesFrame} {i} { +global PgAcVar + # Check if attributes frame is already created for that item + + if {[info exists PgAcVar(fdvar,attributeFrame)]} { + if {$PgAcVar(fdvar,attributeFrame) == $i} return + } + set PgAcVar(fdvar,attributeFrame) $i + + # Delete old widgets from the frame + foreach wid [winfo children .pgaw:FormDesign:attributes.f] { + destroy $wid + } + + set row 0 + set base .pgaw:FormDesign:attributes.f + grid columnconf $base 1 -weight 1 + + set objclass $PgAcVar(fdobj,$i,class) + + # if i is zero, then the object is the form + + if {$i == 0} { + label $base.l$row \ + -borderwidth 0 -text [intlmsg {Startup script}] + entry $base.e$row -textvariable PgAcVar(fdobj,$i,command) \ + -background #fefefe -borderwidth 1 -width 200 + button $base.b$row \ + -borderwidth 1 -padx 1 -pady 0 -text ... -command " + Window show .pgaw:FormDesign:commands + set PgAcVar(fdvar,commandFor) $i + .pgaw:FormDesign:commands.f.txt delete 1.0 end + .pgaw:FormDesign:commands.f.txt insert end \$PgAcVar(fdobj,$i,command)" + grid $base.l$row \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w + grid $base.e$row \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \ + -sticky w + grid $base.b$row \ + -in $base -column 2 -row $row -columnspan 1 -rowspan 1 + incr row + } + + # does it have a text attribute ? + if {[lsearch {button label radio checkbox} $objclass] > -1} { + label $base.l$row \ + -borderwidth 0 -text [intlmsg Text] + entry $base.e$row -textvariable PgAcVar(fdobj,$i,label) \ + -background #fefefe -borderwidth 1 -width 200 + bind $base.e$row <Key-Return> "Forms::design:set_text" + grid $base.l$row \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w + grid $base.e$row \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 -sticky w + incr row + } + + # does it have a variable attribute ? + if {[lsearch {button label radio checkbox entry} $objclass] > -1} { + label $base.l$row \ + -borderwidth 0 -text [intlmsg Variable] + entry $base.e$row -textvariable PgAcVar(fdobj,$i,variable) \ + -background #fefefe -borderwidth 1 -width 200 + grid $base.l$row \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w + grid $base.e$row \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \ + -sticky w + incr row + } + + # does it have a Command attribute ? + if {[lsearch {button checkbox} $objclass] > -1} { + label $base.l$row \ + -borderwidth 0 -text [intlmsg Command] + entry $base.e$row -textvariable PgAcVar(fdobj,$i,command) \ + -background #fefefe -borderwidth 1 -width 200 + button $base.b$row \ + -borderwidth 1 -padx 1 -pady 0 -text ... -command " + Window show .pgaw:FormDesign:commands + set PgAcVar(fdvar,commandFor) $i + .pgaw:FormDesign:commands.f.txt delete 1.0 end + .pgaw:FormDesign:commands.f.txt insert end \$PgAcVar(fdobj,$i,command)" + grid $base.l$row \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w + grid $base.e$row \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \ + -sticky w + grid $base.b$row \ + -in $base -column 2 -row $row -columnspan 1 -rowspan 1 + incr row + } + + # does it have a value attribute ? + if {[lsearch {radio checkbox} $objclass] > -1} { + label $base.l$row \ + -borderwidth 0 -text [intlmsg Value] + entry $base.e$row -textvariable PgAcVar(fdobj,$i,value) \ + -background #fefefe -borderwidth 1 -width 200 + grid $base.l$row \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w + grid $base.e$row \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \ + -sticky w + incr row + } + + # does it have fonts ? + if {[lsearch {label button entry listbox text checkbox radio} $objclass] > -1} { + label $base.lfont \ + -borderwidth 0 -text [intlmsg Font] + grid $base.lfont \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -pady 2 -sticky w + entry $base.efont -textvariable PgAcVar(fdobj,$i,font) \ + -background #fefefe -borderwidth 1 -width 200 + bind $base.efont <Key-Return> "Forms::design:draw_object $i ; set PgAcVar(fdvar,dirty) 1" + grid $base.efont \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 -sticky w + menubutton $base.mbf \ + -borderwidth 1 -menu $base.mbf.m -padx 2 -pady 0 \ + -text {...} -font $PgAcVar(pref,font_normal) -relief raised + menu $base.mbf.m \ + -borderwidth 1 -cursor {} -tearoff 0 -font $PgAcVar(pref,font_normal) + foreach font {normal bold italic fixed} { + $base.mbf.m add command \ + -command " + set PgAcVar(fdobj,$i,font) $font + Forms::design:draw_object $i + set PgAcVar(fdvar,dirty) 1 + " -label $font + } + grid $base.mbf \ + -in $base -column 2 -row $row -columnspan 1 -rowspan 1 -pady 2 -padx 2 -sticky w + incr row + } + + # does it have colors ? + if {[lsearch {label button radio checkbox entry listbox text} $objclass] > -1} { + label $base.lcf \ + -borderwidth 0 -text [intlmsg Foreground] + label $base.scf \ + -background $PgAcVar(fdobj,$i,fcolor) -borderwidth 1 -relief sunken -width 200 + button $base.bcf \ + -command "set tempcolor \[tk_chooseColor -initialcolor $PgAcVar(fdobj,$i,fcolor) -title {Choose color}\] + if {\$tempcolor != {}} { + set PgAcVar(fdobj,$i,fcolor) \$tempcolor + $base.scf configure -background \$PgAcVar(fdobj,$i,fcolor) + set PgAcVar(fdvar,dirty) 1 + Forms::design:draw_object $i + }" \ + -borderwidth 1 -padx 1 -pady 0 -text ... + grid $base.lcf \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w + grid $base.scf \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \ + -sticky w + grid $base.bcf \ + -in $base -column 2 -row $row -columnspan 1 -rowspan 1 + incr row + label $base.lcb \ + -borderwidth 0 -text Background + label $base.scb \ + -background $PgAcVar(fdobj,$i,bcolor) -borderwidth 1 -relief sunken -width 200 + button $base.bcb \ + -command "set tempcolor \[tk_chooseColor -initialcolor $PgAcVar(fdobj,$i,bcolor) -title {Choose color}\] + if {\$tempcolor != {}} { + set PgAcVar(fdobj,$i,bcolor) \$tempcolor + $base.scb configure -background \$PgAcVar(fdobj,$i,bcolor) + set PgAcVar(fdvar,dirty) 1 + Forms::design:draw_object $i + }" \ + -borderwidth 1 -padx 1 -pady 0 -text ... + grid $base.lcb \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w + grid $base.scb \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 -sticky w + grid $base.bcb \ + -in $base -column 2 -row $row -columnspan 1 -rowspan 1 + incr row + } + + # does it have border types ? + if {[lsearch {label button entry listbox text} $objclass] > -1} { + label $base.lrelief \ + -borderwidth 0 -text [intlmsg Relief] + grid $base.lrelief \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -pady 2 -sticky w + menubutton $base.mb \ + -borderwidth 2 -menu $base.mb.m -padx 4 -pady 3 -width 100 -relief $PgAcVar(fdobj,$i,relief) \ + -text groove -textvariable PgAcVar(fdobj,$i,relief) \ + -font $PgAcVar(pref,font_normal) + menu $base.mb.m \ + -borderwidth 1 -cursor {} -tearoff 0 -font $PgAcVar(pref,font_normal) + foreach brdtype {raised sunken ridge groove flat} { + $base.mb.m add command \ + -command " + set PgAcVar(fdobj,$i,relief) $brdtype + $base.mb configure -relief \$PgAcVar(fdobj,$i,relief) + Forms::design:draw_object $i + " -label $brdtype + } + grid $base.mb \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -pady 2 -padx 2 -sticky w + incr row + + } + + # is it a DataControl ? + if {$objclass == "query"} { + label $base.l$row \ + -borderwidth 0 -text [intlmsg SQL] + entry $base.e$row -textvariable PgAcVar(fdobj,$i,command) \ + -background #fefefe -borderwidth 1 -width 200 + grid $base.l$row \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w + grid $base.e$row \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \ + -sticky w + incr row + } + + # does it have a borderwidth attribute ? + if {[lsearch {button label radio checkbox entry listbox text} $objclass] > -1} { + label $base.l$row \ + -borderwidth 0 -text [intlmsg {Border width}] + entry $base.e$row -textvariable PgAcVar(fdobj,$i,borderwidth) \ + -background #fefefe -borderwidth 1 -width 200 + grid $base.l$row \ + -in $base -column 0 -row $row -columnspan 1 -rowspan 1 -sticky w + grid $base.e$row \ + -in $base -column 1 -row $row -columnspan 1 -rowspan 1 -padx 2 \ + -sticky w + incr row + } + + + # The last dummy label + + label $base.ldummy -text {} -borderwidth 0 + grid $base.ldummy -in $base -column 0 -row 100 + grid rowconf $base 100 -weight 1 + +} + + +proc {design:show_attributes} {i} { +global PgAcVar + set objclass $PgAcVar(fdobj,$i,class) + set PgAcVar(fdvar,c_class) $objclass + design:createAttributesFrame $i + set PgAcVar(fdvar,c_name) $PgAcVar(fdobj,$i,name) + if {$i == 0} { + # Object 0 is the form + set c [split [winfo geometry .pgaw:FormDesign:draft] x+] + set PgAcVar(fdvar,c_top) [lindex $c 3] + set PgAcVar(fdvar,c_left) [lindex $c 2] + set PgAcVar(fdvar,c_width) [lindex $c 0] + set PgAcVar(fdvar,c_height) [lindex $c 1] + return + } + set c $PgAcVar(fdobj,$i,coord) + set PgAcVar(fdvar,c_top) [lindex $c 1] + set PgAcVar(fdvar,c_left) [lindex $c 0] + set PgAcVar(fdvar,c_width) [expr [lindex $c 2]-[lindex $c 0]] + set PgAcVar(fdvar,c_height) [expr [lindex $c 3]-[lindex $c 1]] +} + + +proc {design:run} {} { +global PgAcVar CurrentDB DataControlVar +set base .$PgAcVar(fdobj,0,name) +if {[winfo exists $base]} { + wm deiconify $base; return +} +toplevel $base -class Toplevel +wm focusmodel $base passive +wm geometry $base $PgAcVar(fdvar,geometry) +wm maxsize $base 785 570 +wm minsize $base 1 1 +wm overrideredirect $base 0 +wm resizable $base 1 1 +wm deiconify $base +wm title $base $PgAcVar(fdvar,formtitle) +foreach item $PgAcVar(fdvar,objlist) { +set coord $PgAcVar(fdobj,$item,coord) +set name $PgAcVar(fdobj,$item,name) +set wh "-width [expr 3+[lindex $coord 2]-[lindex $coord 0]] -height [expr 3+[lindex $coord 3]-[lindex $coord 1]]" +set visual 1 + +set wfont $PgAcVar(fdobj,$item,font) +switch $wfont { + {} {set wfont $PgAcVar(pref,font_normal)} + normal {set wfont $PgAcVar(pref,font_normal)} + bold {set wfont $PgAcVar(pref,font_bold)} + italic {set wfont $PgAcVar(pref,font_italic)} + fixed {set wfont $PgAcVar(pref,font_fix)} +} + +namespace forget ::DataControl($base.$name) + +# Checking if relief ridge or groove has borderwidth 2 +if {[lsearch {ridge groove} $PgAcVar(fdobj,$item,relief)] != -1} { + if {$PgAcVar(fdobj,$item,borderwidth) < 2} { + set PgAcVar(fdobj,$item,borderwidth) 2 + } +} + +# Checking if borderwidth is okay +if {[lsearch {0 1 2 3 4 5} $PgAcVar(fdobj,$item,borderwidth)] == -1} { + set PgAcVar(fdobj,$item,borderwidth) 1 +} + +set cmd {} +catch {set cmd $PgAcVar(fdobj,$item,command)} + +switch $PgAcVar(fdobj,$item,class) { + button { + button $base.$name -borderwidth 1 -padx 0 -pady 0 -text "$PgAcVar(fdobj,$item,label)" \ + -fg $PgAcVar(fdobj,$item,fcolor) -bg $PgAcVar(fdobj,$item,bcolor) \ + -borderwidth $PgAcVar(fdobj,$item,borderwidth) \ + -relief $PgAcVar(fdobj,$item,relief) -font $wfont -command [subst {$cmd}] + if {$PgAcVar(fdobj,$item,variable) != ""} { + $base.$name configure -textvariable $PgAcVar(fdobj,$item,variable) + } + } + checkbox { + checkbutton $base.$name -onvalue t -offvalue f -font $wfont \ + -fg $PgAcVar(fdobj,$item,fcolor) \ + -borderwidth $PgAcVar(fdobj,$item,borderwidth) \ + -command [subst {$cmd}] \ + -text "$PgAcVar(fdobj,$item,label)" -variable "$PgAcVar(fdobj,$item,variable)" -borderwidth 1 + set wh {} + } + query { + set visual 0 + set DataControlVar($base.$name,sql) $PgAcVar(fdobj,$item,command) + namespace eval ::DataControl($base.$name) "proc open {} { + global CurrentDB DataControlVar + variable tuples + catch {unset tuples} + set wn \[focus\] ; setCursor CLOCK + set res \[wpg_exec \$CurrentDB \"\$DataControlVar($base.$name,sql)\"\] + pg_result \$res -assign tuples + set fl {} + foreach fd \[pg_result \$res -lAttributes\] {lappend fl \[lindex \$fd 0\]} + set DataControlVar($base.$name,fields) \$fl + set DataControlVar($base.$name,recno) 0 + set DataControlVar($base.$name,nrecs) \[pg_result \$res -numTuples\] + setCursor NORMAL + }" + namespace eval ::DataControl($base.$name) "proc setSQL {sqlcmd} { + global DataControlVar + set DataControlVar($base.$name,sql) \$sqlcmd + }" + namespace eval ::DataControl($base.$name) "proc getRowCount {} { + global DataControlVar + return \$DataControlVar($base.$name,nrecs) + }" + namespace eval ::DataControl($base.$name) "proc getRowIndex {} { + global DataControlVar + return \$DataControlVar($base.$name,recno) + }" + namespace eval ::DataControl($base.$name) "proc moveTo {newrecno} { + global DataControlVar + set DataControlVar($base.$name,recno) \$newrecno + }" + namespace eval ::DataControl($base.$name) "proc close {} { + variable tuples + catch {unset tuples} + }" + namespace eval ::DataControl($base.$name) "proc getFieldList {} { + global DataControlVar + return \$DataControlVar($base.$name,fields) + }" + namespace eval ::DataControl($base.$name) "proc fill {lb fld} { + global DataControlVar + variable tuples + \$lb delete 0 end + for {set i 0} {\$i<\$DataControlVar($base.$name,nrecs)} {incr i} { + \$lb insert end \$tuples\(\$i,\$fld\) + } + }" + namespace eval ::DataControl($base.$name) "proc moveFirst {} {global DataControlVar ; set DataControlVar($base.$name,recno) 0}" + namespace eval ::DataControl($base.$name) "proc moveNext {} {global DataControlVar ; incr DataControlVar($base.$name,recno) ; if {\$DataControlVar($base.$name,recno)==\[getRowCount\]} {moveLast}}" + namespace eval ::DataControl($base.$name) "proc movePrevious {} {global DataControlVar ; incr DataControlVar($base.$name,recno) -1 ; if {\$DataControlVar($base.$name,recno)==-1} {moveFirst}}" + namespace eval ::DataControl($base.$name) "proc moveLast {} {global DataControlVar ; set DataControlVar($base.$name,recno) \[expr \[getRowCount\] -1\]}" + namespace eval ::DataControl($base.$name) "proc updateDataSet {} {\ + global DataControlVar + global DataSet + variable tuples + set i \$DataControlVar($base.$name,recno) + foreach fld \$DataControlVar($base.$name,fields) { + catch { + upvar DataSet\($base.$name,\$fld\) dbvar + set dbvar \$tuples\(\$i,\$fld\) + } + } + }" + namespace eval ::DataControl($base.$name) "proc clearDataSet {} { + global DataControlVar + global DataSet + catch { foreach fld \$DataControlVar($base.$name,fields) { + catch { + upvar DataSet\($base.$name,\$fld\) dbvar + set dbvar {} + } + }} + }" + } + radio { + radiobutton $base.$name -font $wfont -text "$PgAcVar(fdobj,$item,label)" \ + -fg $PgAcVar(fdobj,$item,fcolor) -bg $PgAcVar(fdobj,$item,bcolor) -variable $PgAcVar(fdobj,$item,variable) \ + -value $PgAcVar(fdobj,$item,value) -borderwidth 1 + set wh {} + } + entry { + set var {} ; catch {set var $PgAcVar(fdobj,$item,variable)} + entry $base.$name -bg $PgAcVar(fdobj,$item,bcolor) -fg $PgAcVar(fdobj,$item,fcolor) \ + -borderwidth $PgAcVar(fdobj,$item,borderwidth) -font $wfont \ + -relief $PgAcVar(fdobj,$item,relief) -selectborderwidth 0 -highlightthickness 0 + if {$var!=""} {$base.$name configure -textvar $var} + } + text { + text $base.$name -fg $PgAcVar(fdobj,$item,fcolor) -bg $PgAcVar(fdobj,$item,bcolor) \ + -relief $PgAcVar(fdobj,$item,relief) -borderwidth $PgAcVar(fdobj,$item,borderwidth) \ + -font $wfont + } + label { + # set wh {} + label $base.$name -font $wfont -anchor nw -padx 0 -pady 0 -text $PgAcVar(fdobj,$item,label) \ + -borderwidth $PgAcVar(fdobj,$item,borderwidth) \ + -relief $PgAcVar(fdobj,$item,relief) -fg $PgAcVar(fdobj,$item,fcolor) -bg $PgAcVar(fdobj,$item,bcolor) + set var {} ; catch {set var $PgAcVar(fdobj,$item,variable)} + if {$var!=""} {$base.$name configure -textvar $var} + } + listbox { + listbox $base.$name -bg $PgAcVar(fdobj,$item,bcolor) -highlightthickness 0 -selectborderwidth 0 \ + -borderwidth $PgAcVar(fdobj,$item,borderwidth) -relief $PgAcVar(fdobj,$item,relief) \ + -fg $PgAcVar(fdobj,$item,fcolor) -bg $PgAcVar(fdobj,$item,bcolor) -font $wfont -yscrollcommand [subst {$base.sb$name set}] + scrollbar $base.sb$name -borderwidth 1 -command [subst {$base.$name yview}] -orient vert -highlightthickness 0 + eval [subst "place $base.sb$name -x [expr [lindex $coord 2]-14] -y [expr [lindex $coord 1]-1] -width 16 -height [expr 3+[lindex $coord 3]-[lindex $coord 1]] -anchor nw -bordermode ignore"] + } +} +if $visual {eval [subst "place $base.$name -x [expr [lindex $coord 0]-1] -y [expr [lindex $coord 1]-1] -anchor nw $wh -bordermode ignore"]} +} +if {$PgAcVar(fdobj,0,command) != ""} { + uplevel #0 $PgAcVar(fdobj,0,command) +} +} + +proc {design:close} {} { +global PgAcVar + if {$PgAcVar(fdvar,dirty)} { + if {[tk_messageBox -title [intlmsg Warning] -message [intlmsg "Do you want to save the form into the database?"] -type yesno -default yes]=="yes"} { + if {[design:save $PgAcVar(fdvar,formtitle)]==0} {return} + } + } + catch {Window destroy .pgaw:FormDesign:draft} + catch {Window destroy .pgaw:FormDesign:toolbar} + catch {Window destroy .pgaw:FormDesign:menu} + catch {Window destroy .pgaw:FormDesign:attributes} + catch {Window destroy .pgaw:FormDesign:commands} + catch {Window destroy .$PgAcVar(fdobj,0,name)} +} + +} + +proc vTclWindow.pgaw:FormDesign:draft {base} { + if {$base == ""} { + set base .pgaw:FormDesign:draft + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 377x315+50+130 + wm maxsize $base 785 570 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm deiconify $base + wm title $base [intlmsg "Form design"] + bind $base <Key-Delete> { + Forms::design:delete_object + } + bind $base <Key-F1> "Help::load form_design" + canvas $base.c \ + -background #a0a0a0 -height 207 -highlightthickness 0 -relief ridge \ + -selectborderwidth 0 -width 295 + bind $base.c <Button-1> { + Forms::design:mouse_down %x %y + } + bind $base.c <ButtonRelease-1> { + Forms::design:mouse_up %x %y + } + bind $base.c <Motion> { + Forms::design:mouse_move %x %y + } + pack $base.c \ + -in .pgaw:FormDesign:draft -anchor center -expand 1 -fill both -side top +} + +proc vTclWindow.pgaw:FormDesign:attributes {base} { + if {$base == ""} { + set base .pgaw:FormDesign:attributes + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 237x300+461+221 + wm maxsize $base 785 570 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 0 0 + wm deiconify $base + wm title $base [intlmsg "Attributes"] + + # The identification frame + + frame $base.fi \ + -borderwidth 2 -height 75 -relief groove -width 125 + label $base.fi.lclass \ + -borderwidth 0 -text [intlmsg Class] + entry $base.fi.eclass -textvariable PgAcVar(fdvar,c_class) \ + -borderwidth 1 -width 200 + label $base.fi.lname \ + -borderwidth 0 -text [intlmsg Name] + entry $base.fi.ename -textvariable PgAcVar(fdvar,c_name) \ + -background #fefefe -borderwidth 1 -width 200 + bind $base.fi.ename <Key-Return> { + Forms::design:set_name + } + + + # The geometry frame + + frame $base.fg \ + -borderwidth 2 -height 75 -relief groove -width 125 + entry $base.fg.e1 -textvariable PgAcVar(fdvar,c_width) \ + -background #fefefe -borderwidth 1 -width 5 + entry $base.fg.e2 -textvariable PgAcVar(fdvar,c_height) \ + -background #fefefe -borderwidth 1 -width 5 + entry $base.fg.e3 -textvariable PgAcVar(fdvar,c_left) \ + -background #fefefe -borderwidth 1 -width 5 + entry $base.fg.e4 -textvariable PgAcVar(fdvar,c_top) \ + -background #fefefe -borderwidth 1 -width 5 + bind $base.fg.e1 <Key-Return> { + Forms::design:change_coords + } + bind $base.fg.e2 <Key-Return> { + Forms::design:change_coords + } + bind $base.fg.e3 <Key-Return> { + Forms::design:change_coords + } + bind $base.fg.e4 <Key-Return> { + Forms::design:change_coords + } + label $base.fg.l1 \ + -borderwidth 0 -text Width + label $base.fg.l2 \ + -borderwidth 0 -text Height + label $base.fg.l3 \ + -borderwidth 0 -text Left + label $base.fg.l4 \ + -borderwidth 0 -text Top + label $base.fg.lx1 \ + -borderwidth 0 -text x + label $base.fg.lp1 \ + -borderwidth 0 -text + + label $base.fg.lp2 \ + -borderwidth 0 -text + + + # The frame for the rest of the attributes (dynamically generated) + + + frame $base.f \ + -borderwidth 2 -height 75 -relief groove -width 125 + + + # Geometry for "identification frame" + + + place $base.fi \ + -x 5 -y 5 -width 230 -height 55 -anchor nw -bordermode ignore + grid columnconf $base.fi 1 -weight 1 + grid $base.fi.lclass \ + -in $base.fi -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky w + grid $base.fi.eclass \ + -in $base.fi -column 1 -row 0 -columnspan 1 -rowspan 1 -padx 2 \ + -sticky w + grid $base.fi.lname \ + -in $base.fi -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky w + grid $base.fi.ename \ + -in $base.fi -column 1 -row 1 -columnspan 1 -rowspan 1 -padx 2 \ + -sticky w + + + + # Geometry for "geometry frame" + + place $base.fg \ + -x 5 -y 60 -width 230 -height 45 -anchor nw -bordermode ignore + grid $base.fg.e1 \ + -in $base.fg -column 0 -row 0 -columnspan 1 -rowspan 1 + grid $base.fg.e2 \ + -in $base.fg -column 2 -row 0 -columnspan 1 -rowspan 1 + grid $base.fg.e3 \ + -in $base.fg -column 4 -row 0 -columnspan 1 -rowspan 1 + grid $base.fg.e4 \ + -in $base.fg -column 6 -row 0 -columnspan 1 -rowspan 1 + grid $base.fg.l1 \ + -in $base.fg -column 0 -row 1 -columnspan 1 -rowspan 1 + grid $base.fg.l2 \ + -in $base.fg -column 2 -row 1 -columnspan 1 -rowspan 1 + grid $base.fg.l3 \ + -in $base.fg -column 4 -row 1 -columnspan 1 -rowspan 1 + grid $base.fg.l4 \ + -in $base.fg -column 6 -row 1 -columnspan 1 -rowspan 1 + grid $base.fg.lx1 \ + -in $base.fg -column 1 -row 0 -columnspan 1 -rowspan 1 + grid $base.fg.lp1 \ + -in $base.fg -column 5 -row 0 -columnspan 1 -rowspan 1 + grid $base.fg.lp2 \ + -in $base.fg -column 3 -row 0 -columnspan 1 -rowspan 1 + + place $base.f -x 5 -y 105 -width 230 -height 190 -anchor nw + +} + + +proc vTclWindow.pgaw:FormDesign:commands {base} { +global PgAcVar + if {$base == ""} { + set base .pgaw:FormDesign:commands + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 640x480+120+100 + wm maxsize $base 785 570 + wm minsize $base 1 19 + wm overrideredirect $base 0 + wm resizable $base 1 1 + wm title $base [intlmsg "Command"] + frame $base.f \ + -borderwidth 2 -height 75 -relief groove -width 125 + scrollbar $base.f.sb \ + -borderwidth 1 -command {.pgaw:FormDesign:commands.f.txt yview} -orient vert -width 12 + text $base.f.txt \ + -font $PgAcVar(pref,font_fix) -height 1 -tabs {20 40 60 80 100 120 140 160 180 200} \ + -width 200 -yscrollcommand {.pgaw:FormDesign:commands.f.sb set} + frame $base.fb \ + -height 75 -width 125 + button $base.fb.b1 \ + -borderwidth 1 \ + -command { + set PgAcVar(fdobj,$PgAcVar(fdvar,commandFor),command) [.pgaw:FormDesign:commands.f.txt get 1.0 "end - 1 chars"] + Window hide .pgaw:FormDesign:commands + set PgAcVar(fdvar,dirty) 1 + } -text [intlmsg Save] -width 5 + button $base.fb.b2 \ + -borderwidth 1 -command {Window hide .pgaw:FormDesign:commands} \ + -text [intlmsg Cancel] + pack $base.f \ + -in .pgaw:FormDesign:commands -anchor center -expand 1 -fill both -side top + pack $base.f.sb \ + -in .pgaw:FormDesign:commands.f -anchor e -expand 1 -fill y -side right + pack $base.f.txt \ + -in .pgaw:FormDesign:commands.f -anchor center -expand 1 -fill both -side top + pack $base.fb \ + -in .pgaw:FormDesign:commands -anchor center -expand 0 -fill none -side top + pack $base.fb.b1 \ + -in .pgaw:FormDesign:commands.fb -anchor center -expand 0 -fill none -side left + pack $base.fb.b2 \ + -in .pgaw:FormDesign:commands.fb -anchor center -expand 0 -fill none -side top +} + +proc vTclWindow.pgaw:FormDesign:menu {base} { + if {$base == ""} { + set base .pgaw:FormDesign:menu + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + toplevel $base -class Toplevel + wm focusmodel $base passive + wm geometry $base 432x74+0+0 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 0 0 + wm deiconify $base + wm title $base [intlmsg "Form designer"] + frame $base.f1 \ + -height 75 -relief groove -width 125 + label $base.f1.l1 \ + -borderwidth 0 -text "[intlmsg {Form name}] " + entry $base.f1.e1 \ + -background #fefefe -borderwidth 1 -textvariable PgAcVar(fdvar,formtitle) + frame $base.f2 \ + -height 75 -relief groove -width 125 + label $base.f2.l \ + -borderwidth 0 -text "[intlmsg {Form's window internal name}] " + entry $base.f2.e \ + -background #fefefe -borderwidth 1 -textvariable PgAcVar(fdobj,0,name) + frame $base.f3 \ + -height 1 -width 125 + button $base.f3.b1 \ + -command {set PgAcVar(fdvar,geometry) [wm geometry .pgaw:FormDesign:draft] ; Forms::design:run} -padx 1 \ + -text [intlmsg {Test form}] + button $base.f3.b2 \ + -command {destroy .$PgAcVar(fdobj,0,name)} -padx 1 \ + -text [intlmsg {Close test form}] + button $base.f3.b3 \ + -command {Forms::design:save nimic} -padx 1 -text [intlmsg Save] + button $base.f3.b4 \ + -command {Forms::design:close} \ + -padx 1 -text [intlmsg Close] + pack $base.f1 \ + -in .pgaw:FormDesign:menu -anchor center -expand 0 -fill x -pady 2 -side top + pack $base.f1.l1 \ + -in .pgaw:FormDesign:menu.f1 -anchor center -expand 0 -fill none -side left + pack $base.f1.e1 \ + -in .pgaw:FormDesign:menu.f1 -anchor center -expand 1 -fill x -side left + pack $base.f2 \ + -in .pgaw:FormDesign:menu -anchor center -expand 0 -fill x -pady 1 -side top + pack $base.f2.l \ + -in .pgaw:FormDesign:menu.f2 -anchor center -expand 0 -fill none -side left + pack $base.f2.e \ + -in .pgaw:FormDesign:menu.f2 -anchor center -expand 1 -fill x -side left + pack $base.f3 \ + -in .pgaw:FormDesign:menu -anchor center -expand 0 -fill x -pady 2 -side bottom + pack $base.f3.b1 \ + -in .pgaw:FormDesign:menu.f3 -anchor center -expand 0 -fill none -side left + pack $base.f3.b2 \ + -in .pgaw:FormDesign:menu.f3 -anchor center -expand 0 -fill none -side left + pack $base.f3.b3 \ + -in .pgaw:FormDesign:menu.f3 -anchor center -expand 0 -fill none -side left + pack $base.f3.b4 \ + -in .pgaw:FormDesign:menu.f3 -anchor center -expand 0 -fill none -side right +} + + +proc vTclWindow.pgaw:FormDesign:toolbar {base} { +global PgAcVar + foreach wid {button frame radiobutton checkbutton label text entry listbox query} { + image create photo "icon_$wid" -file [file join $PgAcVar(PGACCESS_HOME) images icon_$wid.gif] + } + if {$base == ""} { + set base .pgaw:FormDesign:toolbar + } + if {[winfo exists $base]} { + wm deiconify $base; return + } + toplevel $base -class Toplevel -menu .pgaw:FormDesign:toolbar.m17 + wm focusmodel $base passive + wm geometry $base 29x235+1+130 + wm maxsize $base 1009 738 + wm minsize $base 1 1 + wm overrideredirect $base 0 + wm resizable $base 0 0 + wm deiconify $base + wm title $base [intlmsg "Toolbar"] + button $base.b1 \ + -borderwidth 1 -command {set PgAcVar(fdvar,tool) button} -image icon_button \ + -padx 9 -pady 3 + button $base.b3 \ + -borderwidth 1 -command {set PgAcVar(fdvar,tool) radio} \ + -image icon_radiobutton -padx 9 -pady 3 + button $base.b4 \ + -borderwidth 1 -command {set PgAcVar(fdvar,tool) checkbox} \ + -image icon_checkbutton -padx 9 -pady 3 + button $base.b5 \ + -borderwidth 1 -command {set PgAcVar(fdvar,tool) label} -image icon_label \ + -padx 9 -pady 3 + button $base.b6 \ + -borderwidth 1 -command {set PgAcVar(fdvar,tool) text} -image icon_text \ + -padx 9 -pady 3 + button $base.b7 \ + -borderwidth 1 -command {set PgAcVar(fdvar,tool) entry} -image icon_entry \ + -padx 9 -pady 3 + button $base.b8 \ + -borderwidth 1 -command {set PgAcVar(fdvar,tool) listbox} -image icon_listbox \ + -padx 9 -pady 3 + button $base.b9 \ + -borderwidth 1 -command {set PgAcVar(fdvar,tool) query} -height 21 \ + -image icon_query -padx 9 -pady 3 -width 20 + grid $base.b1 \ + -in .pgaw:FormDesign:toolbar -column 0 -row 2 -columnspan 1 -rowspan 1 + grid $base.b3 \ + -in .pgaw:FormDesign:toolbar -column 0 -row 4 -columnspan 1 -rowspan 1 + grid $base.b4 \ + -in .pgaw:FormDesign:toolbar -column 0 -row 5 -columnspan 1 -rowspan 1 + grid $base.b5 \ + -in .pgaw:FormDesign:toolbar -column 0 -row 0 -columnspan 1 -rowspan 1 + grid $base.b6 \ + -in .pgaw:FormDesign:toolbar -column 0 -row 6 -columnspan 1 -rowspan 1 + grid $base.b7 \ + -in .pgaw:FormDesign:toolbar -column 0 -row 1 -columnspan 1 -rowspan 1 + grid $base.b8 \ + -in .pgaw:FormDesign:toolbar -column 0 -row 7 -columnspan 1 -rowspan 1 + grid $base.b9 \ + -in .pgaw:FormDesign:toolbar -column 0 -row 8 -columnspan 2 -rowspan 3 +} + |