diff options
Diffstat (limited to 'src/bin/pgaccess/lib/forms.tcl')
| -rw-r--r-- | src/bin/pgaccess/lib/forms.tcl | 1263 |
1 files changed, 0 insertions, 1263 deletions
diff --git a/src/bin/pgaccess/lib/forms.tcl b/src/bin/pgaccess/lib/forms.tcl deleted file mode 100644 index 631c3537c72..00000000000 --- a/src/bin/pgaccess/lib/forms.tcl +++ /dev/null @@ -1,1263 +0,0 @@ -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 -} - |