################################# # GLOBAL VARIABLES # global qlvar; global widget; ################################# # USER DEFINED PROCEDURES # proc init {argc argv} { global qlvar set qlvar(yoffs) 360 set qlvar(xoffs) 50 set qlvar(reswidth) 150 } init $argc $argv proc main {argc argv} { } proc show_message {usrmsg} { global msg set msg $usrmsg after 2000 {set msg {}} } proc ql_delete_object {} { global qlvar # Checking if there set obj [.c find withtag hili] if {$obj==""} return if {[ql_get_tag_info $obj link]=="s"} { # if {[tk_messageBox -title WARNING -icon question -message "Remove link ?" -type yesno -default no]=="no"} return show_message "Deleting the link from tables ..." set linkid [ql_get_tag_info $obj lkid] set qlvar(links) [lreplace $qlvar(links) $linkid $linkid] .c delete links ql_draw_links } else { set tablename [ql_get_tag_info $obj tab] if {$tablename==""} return # if {[tk_messageBox -title WARNING -icon question -message "Remove table $tablename from query ?" -type yesno -default no]=="no"} return show_message "Deleting table from query ..." for {set i [expr [llength $qlvar(restables)]-1]} {$i>=0} {incr i -1} { if {$tablename==[lindex $qlvar(restables) $i]} { set qlvar(resfields) [lreplace $qlvar(resfields) $i $i] set qlvar(restables) [lreplace $qlvar(restables) $i $i] set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $i $i] } } for {set i [expr [llength $qlvar(links)]-1]} {$i>=0} {incr i -1} { set thelink [lindex $qlvar(links) $i] if {($tablename==[lindex $thelink 0]) || ($tablename==[lindex $thelink 2])} { set qlvar(links) [lreplace $qlvar(links) $i $i] } } .c delete tab$tablename .c delete links ql_draw_links ql_draw_res_panel } } proc ql_dragit {w x y} { global draginfo if {"$draginfo(obj)" != ""} { set dx [expr $x - $draginfo(x)] set dy [expr $y - $draginfo(y)] if {$draginfo(is_a_table)} { set taglist [.c gettags $draginfo(obj)] set tabletag [lindex $taglist [lsearch -regexp $taglist "^tab"]] $w move $tabletag $dx $dy ql_draw_links } else { $w move $draginfo(obj) $dx $dy } set draginfo(x) $x set draginfo(y) $y } } proc ql_dragstart {w x y} { global draginfo catch {unset draginfo} set draginfo(obj) [$w find closest $x $y] if {[ql_get_tag_info $draginfo(obj) r]=="ect"} { # If it'a a rectangle, exit set draginfo(obj) {} return } . configure -cursor hand1 .c raise $draginfo(obj) set draginfo(table) 0 if {[ql_get_tag_info $draginfo(obj) table]=="header"} { set draginfo(is_a_table) 1 .c itemconfigure [.c find withtag hili] -fill black .c dtag [.c find withtag hili] hili .c addtag hili withtag $draginfo(obj) .c itemconfigure hili -fill blue } else { set draginfo(is_a_table) 0 } set draginfo(x) $x set draginfo(y) $y set draginfo(sx) $x set draginfo(sy) $y } proc ql_dragstop {x y} { global draginfo qlvar . configure -cursor top_left_arrow set este {} catch {set este $draginfo(obj)} if {$este==""} return # Re-establish the normal paint order so # information won't be overlapped by table rectangles # or link linkes .c lower $draginfo(obj) .c lower rect .c lower links set qlvar(panstarted) 0 if {$draginfo(is_a_table)} { set draginfo(obj) {} .c delete links ql_draw_links return } .c move $draginfo(obj) [expr $draginfo(sx)-$x] [expr $draginfo(sy)-$y] if {($y>$qlvar(yoffs)) && ($x>$qlvar(xoffs))} { # Drop position : inside the result panel # Compute the offset of the result panel due to panning set resoffset [expr [lindex [.c bbox resmarker] 0]-$qlvar(xoffs)] set newfld [.c itemcget $draginfo(obj) -text] set tabtag [ql_get_tag_info $draginfo(obj) tab] set col [expr int(($x-$qlvar(xoffs)-$resoffset)/$qlvar(reswidth))] set qlvar(resfields) [linsert $qlvar(resfields) $col $newfld] set qlvar(ressort) [linsert $qlvar(ressort) $col unsorted] set qlvar(rescriteria) [linsert $qlvar(rescriteria) $col {}] set qlvar(restables) [linsert $qlvar(restables) $col $tabtag] ql_draw_res_panel } else { # Drop position : in the table panel set droptarget [.c find overlapping $x $y $x $y] set targettable {} foreach item $droptarget { set targettable [ql_get_tag_info $item tab] set targetfield [ql_get_tag_info $item f-] if {($targettable!="") && ($targetfield!="")} { set droptarget $item break } } # check if target object isn't a rectangle if {[ql_get_tag_info $droptarget rec]=="t"} {set targettable {}} if {$targettable!=""} { # Target has a table # See about originate table set sourcetable [ql_get_tag_info $draginfo(obj) tab] if {$sourcetable!=""} { # Source has also a tab .. tag set sourcefield [ql_get_tag_info $draginfo(obj) f-] if {$sourcetable!=$targettable} { lappend qlvar(links) [list $sourcetable $sourcefield $targettable $targetfield $draginfo(obj) $droptarget] ql_draw_links } } } } # Erase information about onbject beeing dragged set draginfo(obj) {} } proc ql_draw_links {} { global qlvar .c delete links set i 0 foreach link $qlvar(links) { # Compute the source and destination right edge set sre [lindex [.c bbox tab[lindex $link 0]] 2] set dre [lindex [.c bbox tab[lindex $link 2]] 2] # Compute field bound boxes set sbbox [.c bbox [lindex $link 4]] set dbbox [.c bbox [lindex $link 5]] # Compute the auxiliary lines if {[lindex $sbbox 2] < [lindex $dbbox 0]} { # Source object is on the left of target object set x1 $sre set y1 [expr ([lindex $sbbox 1]+[lindex $sbbox 3])/2] .c create line $x1 $y1 [expr $x1+10] $y1 -tags [subst {links lkid$i}] -width 3 set x2 [lindex $dbbox 0] set y2 [expr ([lindex $dbbox 1]+[lindex $dbbox 3])/2] .c create line [expr $x2-10] $y2 $x2 $y2 -tags {links} -width 3 .c create line [expr $x1+10] $y1 [expr $x2-10] $y2 -tags [subst {links lkid$i}] -width 2 } else { # source object is on the right of target object set x1 [lindex $sbbox 0] set y1 [expr ([lindex $sbbox 1]+[lindex $sbbox 3])/2] .c create line $x1 $y1 [expr $x1-10] $y1 -tags [subst {links lkid$i}] -width 3 set x2 $dre set y2 [expr ([lindex $dbbox 1]+[lindex $dbbox 3])/2] .c create line $x2 $y2 [expr $x2+10] $y2 -width 3 -tags [subst {links lkid$i}] .c create line [expr $x1-10] $y1 [expr $x2+10] $y2 -tags [subst {links lkid$i}] -width 2 } incr i } .c lower links .c bind links <Button-1> {ql_link_click %x %y} } proc ql_draw_lizzard {} { global qlvar ql_read_struct .c delete all set posx 20 for {set it 0} {$it<$qlvar(ntables)} {incr it} { ql_draw_table $it # set posy 10 # set tablename $qlvar(tablename$it) # .c create text $posx $posy -text $tablename -anchor nw -tags [subst {tab$tablename f-oid mov tableheader}] -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* # incr posy 16 # foreach fld $qlvar(tablestruct$it) { # .c create text $posx $posy -text $fld -anchor nw -tags [subst {f-$fld tab$tablename mov}] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* # incr posy 14 # } # set reg [.c bbox tab$tablename] # .c create rectangle [lindex $reg 0] [lindex $reg 1] [lindex $reg 2] [lindex $reg 3] -fill #EEEEEE -tags [subst {rect tab$tablename}] # .c create line [lindex $reg 0] [expr [lindex $reg 1]+15] [lindex $reg 2] [expr [lindex $reg 1]+15] -tags [subst {rect tab$tablename}] # set posx [expr $posx+40+[lindex $reg 2]-[lindex $reg 0]] } .c lower rect .c create line 0 $qlvar(yoffs) 10000 $qlvar(yoffs) -width 3 .c create rectangle 0 $qlvar(yoffs) 10000 5000 -fill #FFFFFF for {set i [expr 15+$qlvar(yoffs)]} {$i<500} {incr i 15} { .c create line $qlvar(xoffs) $i 10000 $i -fill #CCCCCC -tags {resgrid} } for {set i $qlvar(xoffs)} {$i<10000} {incr i $qlvar(reswidth)} { .c create line $i [expr 1+$qlvar(yoffs)] $i 10000 -fill #cccccc -tags {resgrid} } # Make a marker for result panel offset calculations (due to panning) .c create line $qlvar(xoffs) $qlvar(yoffs) $qlvar(xoffs) 500 -tags {resmarker resgrid} .c create rectangle 0 $qlvar(yoffs) $qlvar(xoffs) 5000 -fill #EEEEEE -tags {reshdr} .c create text 5 [expr 1+$qlvar(yoffs)] -text Field: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags {reshdr} .c create text 5 [expr 16+$qlvar(yoffs)] -text Table: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags {reshdr} .c create text 5 [expr 31+$qlvar(yoffs)] -text Sort: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags {reshdr} .c create text 5 [expr 46+$qlvar(yoffs)] -text Criteria: -anchor nw -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags {reshdr} .c bind mov <Button-1> {ql_dragstart %W %x %y} .c bind mov <B1-Motion> {ql_dragit %W %x %y} bind . <ButtonRelease-1> {ql_dragstop %x %y} bind . <Button-1> {qlc_click %x %y %W} bind . <B1-Motion> {ql_pan %x %y} bind . <Key-Delete> {ql_delete_object} set qlvar(resfields) {} set qlvar(ressort) {} set qlvar(rescriteria) {} set qlvar(restables) {} set qlvar(critedit) 0 set qlvar(links) {} set qlvar(linktodelete) {} } proc ql_draw_res_panel {} { global qlvar # Compute the offset of the result panel due to panning set resoffset [expr [lindex [.c bbox resmarker] 0]-$qlvar(xoffs)] .c delete resp for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} { .c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 1+$qlvar(yoffs)] -text [lindex $qlvar(resfields) $i] -anchor nw -fill navy -tags {resf resp} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* .c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 16+$qlvar(yoffs)] -text [lindex $qlvar(restables) $i] -anchor nw -tags {resp rest} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* .c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr 31+$qlvar(yoffs)] -text [lindex $qlvar(ressort) $i] -anchor nw -tags {resp sort} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* if {[lindex $qlvar(rescriteria) $i]!=""} { .c create text [expr $resoffset+4+$qlvar(xoffs)+$i*$qlvar(reswidth)] [expr $qlvar(yoffs)+46+15*0] -anchor nw -text [lindex $qlvar(rescriteria) $i] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags [subst {resp cr-c$i-r0}] } } .c raise reshdr .c bind sort <Button-1> {ql_swap_sort %W %x %y} } proc ql_draw_table {it} { global qlvar set posy 10 set allbox [.c bbox rect] if {$allbox==""} {set posx 10} else {set posx [expr 20+[lindex $allbox 2]]} set tablename $qlvar(tablename$it) .c create text $posx $posy -text $tablename -anchor nw -tags [subst {tab$tablename f-oid mov tableheader}] -font -Adobe-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-* incr posy 16 foreach fld $qlvar(tablestruct$it) { .c create text $posx $posy -text $fld -anchor nw -tags [subst {f-$fld tab$tablename mov}] -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* incr posy 14 } set reg [.c bbox tab$tablename] .c create rectangle [lindex $reg 0] [lindex $reg 1] [lindex $reg 2] [lindex $reg 3] -fill #EEEEEE -tags [subst {rect tab$tablename}] .c create line [lindex $reg 0] [expr [lindex $reg 1]+15] [lindex $reg 2] [expr [lindex $reg 1]+15] -tags [subst {rect tab$tablename}] } proc ql_get_tag_info {obj prefix} { set taglist [.c gettags $obj] set tagpos [lsearch -regexp $taglist "^$prefix"] if {$tagpos==-1} {return ""} set thattag [lindex $taglist $tagpos] return [string range $thattag [string length $prefix] end] } proc ql_link_click {x y} { global qlvar set obj [.c find closest $x $y 1 links] if {[ql_get_tag_info $obj link]!="s"} return .c itemconfigure [.c find withtag hili] -fill black .c dtag [.c find withtag hili] hili .c addtag hili withtag $obj .c itemconfigure $obj -fill blue } proc ql_pan {x y} { global qlvar set panstarted 0 catch {set panstarted $qlvar(panstarted) } if {!$panstarted} return set dx [expr $x-$qlvar(panstartx)] set dy [expr $y-$qlvar(panstarty)] set qlvar(panstartx) $x set qlvar(panstarty) $y if {$qlvar(panobject)=="tables"} { .c move mov $dx $dy .c move links $dx $dy .c move rect $dx $dy } else { .c move resp $dx 0 .c move resgrid $dx 0 .c raise reshdr } } proc ql_read_struct {} { global qlvar set qlvar(ntables) 3 set qlvar(tablename0) Facturi set qlvar(tablename1) Nommat set qlvar(tablename2) Incasari set qlvar(tablestruct0) [list factura client valoare tva] set qlvar(tablestruct1) [list cod denumire pret greutate procent_tva] set qlvar(tablestruct2) [list data valoare nrdoc referinta] } proc ql_show_sql {} { global qlvar set sqlcmd "select " for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} { if {$sqlcmd!="select "} {set sqlcmd "$sqlcmd, "} set sqlcmd "$sqlcmd[lindex $qlvar(restables) $i].[lindex $qlvar(resfields) $i]" } set tables {} for {set i 0} {$i<$qlvar(ntables)} {incr i} { lappend tables $qlvar(tablename$i) } set sqlcmd "$sqlcmd from [join $tables ,] " set sup1 {} if {[llength $qlvar(links)]>0} { set sup1 "where " foreach link $qlvar(links) { if {$sup1!="where "} {set sup1 "$sup1 and "} set sup1 "$sup1 ([lindex $link 0].[lindex $link 1]=[lindex $link 2].[lindex $link 3])" } } for {set i 0} {$i<[llength $qlvar(resfields)]} {incr i} { set crit [lindex $qlvar(rescriteria) $i] if {$crit!=""} { if {$sup1==""} {set sup1 "where "} if {[string range $sup1 0 4]=="where"} {set sup1 "$sup1 and "} set sup1 "$sup1 ([lindex $qlvar(restables) $i].[lindex $qlvar(resfields) $i]$crit) " } } set sqlcmd "$sqlcmd $sup1" set sup2 {} for {set i 0} {$i<[llength $qlvar(ressort)]} {incr i} { set how [lindex $qlvar(ressort) $i] if {$how!="unsorted"} { if {$how=="Ascending"} {set how asc} else {set how desc} if {$sup2==""} {set sup2 " order by "} else {set sup2 "$sup2,"} set sup2 "$sup2 [lindex $qlvar(resfields) $i] $how " } } set sqlcmd "$sqlcmd $sup2" set qlvar(sql) $sqlcmd #tk_messageBox -message $sqlcmd .c delete sqlpage .c create rectangle 0 0 2000 [expr $qlvar(yoffs)-1] -fill #ffffff -tags {sqlpage} .c create text 10 10 -text $sqlcmd -anchor nw -width 550 -tags {sqlpage} -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* .c bind sqlpage <Button-1> {.c delete sqlpage} } proc ql_swap_sort {w x y} { global qlvar set obj [$w find closest $x $y] set taglist [.c gettags $obj] if {[lsearch $taglist sort]==-1} return set cum [.c itemcget $obj -text] if {$cum=="unsorted"} { set cum Ascending } elseif {$cum=="Ascending"} { set cum Descending } else { set cum unsorted } set col [expr int(($x-$qlvar(xoffs))/$qlvar(reswidth))] set qlvar(ressort) [lreplace $qlvar(ressort) $col $col $cum] .c itemconfigure $obj -text $cum } proc qlc_click {x y w} { global qlvar set qlvar(panstarted) 0 if {$w==".c"} { set canpan 1 if {$y<$qlvar(yoffs)} { if {[llength [.c find overlapping $x $y $x $y]]!=0} {set canpan 0} set qlvar(panobject) tables } else { set qlvar(panobject) result } if {$canpan} { . configure -cursor hand1 set qlvar(panstartx) $x set qlvar(panstarty) $y set qlvar(panstarted) 1 } } set isedit 0 catch {set isedit $qlvar(critedit)} # Compute the offset of the result panel due to panning set resoffset [expr [lindex [.c bbox resmarker] 0]-$qlvar(xoffs)] if {$isedit} { set qlvar(rescriteria) [lreplace $qlvar(rescriteria) $qlvar(critcol) $qlvar(critcol) $qlvar(critval)] .c delete cr-c$qlvar(critcol)-r$qlvar(critrow) .c create text [expr $resoffset+4+$qlvar(xoffs)+$qlvar(critcol)*$qlvar(reswidth)] [expr $qlvar(yoffs)+46+15*$qlvar(critrow)] -anchor nw -text $qlvar(critval) -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -tags [subst {resp cr-c$qlvar(critcol)-r$qlvar(critrow)}] set qlvar(critedit) 0 } catch {destroy .entc} if {$y<[expr $qlvar(yoffs)+46]} return if {$x<[expr $qlvar(xoffs)+5]} return set col [expr int(($x-$qlvar(xoffs)-$resoffset)/$qlvar(reswidth))] if {$col>=[llength $qlvar(resfields)]} return set nx [expr $col*$qlvar(reswidth)+8+$qlvar(xoffs)+$resoffset] set ny [expr $qlvar(yoffs)+76] # Get the old criteria value set qlvar(critval) [lindex $qlvar(rescriteria) $col] entry .entc -textvar qlvar(critval) -borderwidth 0 -background #FFFFFF -highlightthickness 0 -selectborderwidth 0 -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* place .entc -x $nx -y $ny -height 14 focus .entc bind .entc <Button-1> {set qlvar(panstarted) 0} set qlvar(critcol) $col set qlvar(critrow) 0 set qlvar(critedit) 1 } proc Window {args} { global vTcl set cmd [lindex $args 0] set name [lindex $args 1] set newname [lindex $args 2] set rest [lrange $args 3 end] if {$name == "" || $cmd == ""} {return} if {$newname == ""} { set newname $name } set exists [winfo exists $newname] switch $cmd { show { if {$exists == "1" && $name != "."} {wm deiconify $name; return} if {[info procs vTclWindow(pre)$name] != ""} { eval "vTclWindow(pre)$name $newname $rest" } if {[info procs vTclWindow$name] != ""} { eval "vTclWindow$name $newname $rest" } if {[info procs vTclWindow(post)$name] != ""} { eval "vTclWindow(post)$name $newname $rest" } } hide { if $exists {wm withdraw $newname; return} } iconify { if $exists {wm iconify $newname; return} } destroy { if $exists {destroy $newname; return} } } } set base "" bind $base <B1-Motion> { ql_pan %x %y } bind $base <Button-1> { qlc_click %x %y %W } bind $base <ButtonRelease-1> { ql_dragstop %x %y } bind $base <Key-Delete> { ql_delete_object } canvas $base.c \ -background #fefefe -borderwidth 2 -height 207 -relief ridge \ -takefocus 0 -width 295 label $base.msg -textvar msg -borderwidth 1 -relief sunken button $base.b2 \ -borderwidth 1 -command ql_draw_lizzard \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -pady 3 -text {Paint demo tables} button $base.showbtn \ -borderwidth 1 -command ql_show_sql \ -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-* -padx 9 \ -pady 3 -text {Show SQL} ################### # SETTING GEOMETRY ################### place $base.c \ -x 5 -y 30 -width 578 -height 425 -anchor nw -bordermode ignore place $base.b2 \ -x 5 -y 5 -height 26 -anchor nw -bordermode ignore place $base.showbtn \ -x 130 -y 5 -height 26 -anchor nw -bordermode ignore place $base.msg \ -x 5 -y 460 -width 578 -anchor nw main $argc $argv