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 -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 "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 "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 { Forms::design:delete_object } bind $base "Help::load form_design" canvas $base.c \ -background #a0a0a0 -height 207 -highlightthickness 0 -relief ridge \ -selectborderwidth 0 -width 295 bind $base.c { Forms::design:mouse_down %x %y } bind $base.c { Forms::design:mouse_up %x %y } bind $base.c { 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 { 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 { Forms::design:change_coords } bind $base.fg.e2 { Forms::design:change_coords } bind $base.fg.e3 { Forms::design:change_coords } bind $base.fg.e4 { 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 }