[JOB] 2016-05-03 Playing with TclOO... The following code implements a tablelistbrowser megawidget with the aid of TclOO. [WikiDBImage tablelistbrowser_demo.png] The tablelist operates in "browse" mode, if nothing is selected, the content of each table item is shown on the rhs window on the fly. Current selection is handled within the object (and won't get lost, in case something else is going to be selected). Horizontal / vertical view can be toggled interactively. When doing so, current selected tablelist item is kept visible. Binding for keyboard navigation within the tablelist is available (although quite slow). Found out that: * performance under OSX (tablelist with images) is a bit slow ? * ttk::panedwindow does not allow to dynamically toggle the orientation e.g. with " configure -orient "horizontal"" * tk::panedwindow has to be used instead ? TclOO: * Looks quite promising in respect of megawidget class layout. * Used the [A TclOO tablelist template] as a starting point for the megawidget. Here is the code - pls. enjoy. Of corse any comments are very welcome! * tablelistbrowser.tcl ====== # ----------------------------------------------------------------------------- # tablelistbrowser.tcl --- # ----------------------------------------------------------------------------- # (c) 2016, Johann Oberdorfer - Engineering Support | CAD | Software # johann.oberdorfer [at] gmail.com # www.johann-oberdorfer.eu # ----------------------------------------------------------------------------- # This source file is distributed under the BSD license. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # See the BSD License for more details. # ----------------------------------------------------------------------------- # Purpose: # A TclOO class implementing the tablelistbrowser megawidget. # Might be usefull as a starting point. # ----------------------------------------------------------------------------- # TclOO naming conventions: # public methods - starts with lower case declaration names, whereas # private methods - starts with uppercase naming, so we are going to use CamelCase ... # ----------------------------------------------------------------------------- # for development: try to find autoscroll, etc ... # set this_file [file normalize [file dirname [info script]]] # where to find required packages... # set auto_path [linsert $auto_path 0 [file join $this_file ".."]] package require autoscroll package require tablelist_tile package provide tablelistbrowser 0.1 # workaround for aqua if { [tk windowingsystem] eq "aqua" } { interp alias {} ttk::scrollbar {} ::scrollbar } namespace eval tablelistbrowser { proc LoadImages {image_dir {patterns {*.gif}}} { foreach p $patterns { foreach file [glob -directory $image_dir $p] { set img [file tail [file rootname $file]] if { ![info exists images($img)] } { set images($img) [image create photo -file $file] } }} return [array get images] } # this is a tk-like wrapper around my... class so that # object creation works like other tk widgets proc tablelistbrowser {path args} { set obj [obj_tablelist create tmp $path {*}$args] # rename oldName newName rename $obj ::$path return $path } oo::class create obj_tablelist { variable tblwidget variable widgetOptions variable widgetCompounds constructor {path args} { set this_dir [file dirname [info script]] set image_file [file join $this_dir "ImageLib.tcl"] # --------------------------------------------------------------- # read images from library file or alternatively one by one # --------------------------------------------------------------- if { [file exists $image_file] } { source $image_file array set widgetCompounds [array get images] } else { array set widgetCompounds [LoadImages \ [file join $this_dir "images"] {"*.gif" "*.png"}] } # --------------------------------------------------------------- set this_file [file dirname [info script]] array set widgetCompounds { paneorient "vertical" } # declaration of all additional widget options array set widgetOptions { -xtabheader {} \ } # we use a frame for this specific widget class set f [ttk::frame $path -class tablelistbrowser] # we must rename the widget command # since it clashes with the object being created set widget ${path}_ rename $path $widget my Build $f my configure {*}$args } # add a destructor to clean up the widget destructor { set w [namespace tail [self]] catch {bind $w {}} catch {destroy $w} } method cget { {opt "" } } { my variable tblwidget my variable widgetOptions if { [string length $opt] == 0 } { return [array get widgetOptions] } if { [info exists widgetOptions($opt) ] } { return $widgetOptions($opt) } return [$tblwidget cget $opt] } method configure { args } { my variable tblwidget my variable widgetOptions if {[llength $args] == 0} { # return all tablelist options set opt_list [$tblwidget configure] # as well as all custom options foreach xopt [array get widgetOptions] { lappend opt_list $xopt } return $opt_list } elseif {[llength $args] == 1} { # return configuration value for this option set opt $args if { [info exists widgetOptions($opt) ] } { return $widgetOptions($opt) } return [$tblwidget cget $opt] } # error checking if {[expr {[llength $args]%2}] == 1} { return -code error "value for \"[lindex $args end]\" missing" } # process the new configuration options... array set opts $args foreach opt_name [array names opts] { set opt_value $opts($opt_name) # overwrite with new value if { [info exists widgetOptions($opt_name)] } { set widgetOptions($opt_name) $opt_value } # some options need action from the widgets side switch -- $opt_name { -xtabheader { my InitializeTabHeader $opt_value my AddTextTags } default { # ------------------------------------------------------- # if the configure option wasn't one of our special one's, # pass control over to the original tablelist widget # ------------------------------------------------------- if {[catch {$tblwidget configure $opt_name $opt_value} result]} { return -code error $result } } } } } # overloaded tablelist method ! method insert {method args} { my variable tblwidget if {[catch {$tblwidget insert $method {*}$args} result]} { return -code error $result } my modifyColumnImage "init" "unused,0" } # -------------------------------------------------- # if the command wasn't one of our special one's, # pass control over to the original tablelist widget # -------------------------------------------------- method unknown {method args} { my variable tblwidget if {[catch {$tblwidget $method {*}$args} result]} { return -code error $result } } } } interp alias {} OOD {} oo::define ::tablelistbrowser::obj_tablelist method # -------------------------------------------------------- # Public Functions / implementation of our new subcommands # -------------------------------------------------------- OOD modifyColumnImage {mode cell_reference} { my variable tblwidget my variable widgetCompounds # cell_reference is formatted as regular cell reference, # which is: "rownum,colnum" set tmp [split $cell_reference ","] set row_num [lindex $tmp 0] set col_num [lindex $tmp 1] # alternatively we could use: # foreach {row_num col_num} [split $cell_reference ","] {} switch -- $mode { "init" { # setup images for the 1st time set cnt 0 foreach item [$tblwidget get 0 end] { $tblwidget cellconfigure "$cnt,$col_num" \ -image $widgetCompounds(img_unchecked) incr cnt } } "toggle_selection" { $tblwidget selection clear 0 end # search for the 1st occurance of img_checked, deselect and continue... set cnt 0 foreach item [$tblwidget get 0 end] { # puts "$cnt,0 ---- $item" if {[$tblwidget cellcget "$cnt,$col_num" -image] == $widgetCompounds(img_checked)} { $tblwidget cellconfigure "$cnt,$col_num" -image $widgetCompounds(img_unchecked) $tblwidget rowconfigure $cnt -font {} -foreground {} -background {} break } incr cnt } } "set_selection" { # finally, do our own selection (which isn't lost, once # another "normal" (text-)widget selection is done ... # ----------------------------------------------------- # check, if this code can be reached ??! # "DarkRed" / "White" $tblwidget cellconfigure "$row_num,$col_num" -image $widgetCompounds(img_checked) $tblwidget rowconfigure $row_num \ -font APP_FONT_STD_BOLD \ -foreground [ttk::style configure . -selectforeground] \ -background [ttk::style configure . -selectbackground] } } } # ----------------------------------------------------------------------------- # returns row number of current selection # or -1 if nothing is selected # ----------------------------------------------------------------------------- OOD tablelistGetSelectedIndex {{col_num 0}} { my variable tblwidget my variable widgetCompounds set cnt 0 foreach item [$tblwidget get 0 end] { if {[$tblwidget cellcget "$cnt,$col_num" -image] == $widgetCompounds(img_checked)} { return $cnt } incr cnt } return -1 } # ----------------------------------------------------------------------------- # ----------------------------------------------------------------------------- OOD displayItemInfo {mode rownum} { my variable tblwidget my variable widgetCompounds set txt $widgetCompounds(txtwidget) # manipulate tablelist (if required) switch -- $mode { "button_pressed" { my modifyColumnImage "toggle_selection" "unused,0" $txt delete 0.0 end } "motion" {} } # show tablelist data item in the text widget set kwd_list [my cget -xtabheader] if {[llength $kwd_list] == 0} { return } set maxattr_len [string length [my GetMaxAttributeString $kwd_list]] set data [lindex [$tblwidget get $rownum $rownum] 0] $txt delete 0.0 end set cnt 0 foreach d $data { set descr [lindex [lindex $kwd_list $cnt] 0] if {[string range $descr end end] != ":"} { append descr ":" } while {[string length $descr] < $maxattr_len} { append descr " " } $txt insert end $descr ATTR_NAME if {$cnt == 0} { $txt insert end "$d " ATTR_TXT0 } else { $txt insert end "$d " ATTR_TXT1 } $txt insert end "\n" incr cnt } } # -------------------- # Private Functions... # -------------------- OOD EnableMoveoverBindings {} { my variable tblwidget # select/deselect ButtonRelease bind [$tblwidget bodypath] { set x [expr {%x + [winfo x %W]}] set y [expr {%y + [winfo y %W]}] set t [winfo parent %W] set cell [$t nearestcell $x $y] set rownum [lindex [split $cell ","] 0] set oo_my [winfo parent $t] while { [winfo exists $oo_my] } { if { [winfo class $oo_my] == "tablelistbrowser" } { break } set oo_my [winfo parent $oo_my] } if {[llength [set idx [$t curselection]]] != 0 && $idx == $rownum} { $oo_my modifyColumnImage "toggle_selection" "unused,0" } else { $oo_my displayItemInfo "button_pressed" $rownum $oo_my modifyColumnImage "set_selection" "$rownum,0" } } # move-over effect: bind [$tblwidget bodypath] {+ set t [winfo parent %W] set x [expr {%x + [winfo x %W]}] set y [expr {%y + [winfo y %W]}] set cell [$t nearestcell $x $y] set rownum [lindex [split $cell ","] 0] set oo_my [winfo parent $t] # move up hierachy until our own class is reached: # notes: # - maybe there is a more convinient way to adress a class member function ? # - pls note that the member function needs to start with lowercase char # otherwise it's hidden in global namespace while { [winfo exists $oo_my] } { if { [winfo class $oo_my] == "tablelistbrowser" } { break } set oo_my [winfo parent $oo_my] } if {[$oo_my tablelistGetSelectedIndex] == -1} { $t selection clear 0 end $oo_my displayItemInfo "motion" $rownum } focus $t $t configure -activestyle frame $t activate "@$x,$y" } # works (but a bit slow): bind $tblwidget { set t %W set key %K if { [lsearch {"Up" "Down"} $key] != -1 && [llength [set idx [$t curselection]]] != 0} { set rownum [lindex $idx 0] set within_bounds 1 if {$key == "Up" && $rownum == 0} { set within_bounds 0 } elseif \ {$key == "Up" && $rownum > 0} { incr rownum -1 } elseif \ {$key == "Down" && $rownum < [expr {[llength [$t get 0 end]] - 1}] } { incr rownum } else { set within_bounds 0 } if {$within_bounds != 0} { set oo_my [winfo parent $t] while { [winfo exists $oo_my] } { if { [winfo class $oo_my] == "tablelistbrowser" } { break } set oo_my [winfo parent $oo_my] } # deselect $oo_my modifyColumnImage "toggle_selection" "unused,0" # select & zoom (if required) $t selection set $rownum $rownum $t see $rownum $oo_my modifyColumnImage "set_selection" "$rownum,0" $oo_my displayItemInfo "motion" $rownum } } } bind [$tblwidget bodypath] {+ set t [winfo parent %W] $t configure -activestyle none } } OOD InitializeTabHeader {kword_list} { my variable tblwidget set cols "" set cnt 0 foreach i $kword_list { set descr [lindex $i 0] set visual [lindex $i 1] set orient [lindex $i 2] if {[string length $orient] == 0} { set orient "left" } regsub -all " " $descr "_" descr if {$descr != "..." && [string range $descr end end] != ":"} { set descr "${descr}:" } # could be either a string or an integer: if {$visual == "hidden"} { set width 20 } else { set width $visual } append cols "$width $descr $orient " incr cnt } $tblwidget configure -columns $cols # hide specific columns as indicated with "hidden" in declaration array set cnt 0 foreach i $kword_list { if {[set width [lindex $i 1]] == "hidden"} { $tblwidget columnconfigure $cnt -hide yes } incr cnt } # expand last *visible* column # ---------------------------- set cnt 0 set lastcol 0 # tablelist -columns option are always 3 attributes each... foreach {w col pos} [$tblwidget cget -columns] { if {[$tblwidget columncget $cnt -hide] == 0} {set lastcol $cnt} incr cnt } if {$lastcol > 0} { $tblwidget configure -stretch $lastcol } } OOD GetTime {} { my variable widgetCompounds set seconds [clock seconds] $widgetCompounds(date) configure -text [clock format $seconds -format "%A %d.%b, %H:%M:%S"] after 1000 "[namespace code {my GetTime}]" } OOD Zoom2Selection {} { my variable tblwidget # standard tablelist behaviour if {[set idx_lst [$tblwidget curselection]] != {}} { $tblwidget see [lindex $idx_lst 0] return } # 2nd approach in the case our custom selection is set set col_num 0 set cnt 0 foreach item [$tblwidget get 0 end] { if {[$tblwidget cellcget "$cnt,$col_num" -image] == $widgetCompounds(img_checked)} { $tblwidget see $cnt break } incr cnt } } OOD TogglePaneOrientation {{mode ""}} { my variable widgetCompounds # "setup image" mode # ------------------ if {$mode != ""} { if {$widgetCompounds(paneorient) == "horizontal"} { set img $widgetCompounds(img_leftright) } else { set img $widgetCompounds(img_topbottom) } $widgetCompounds(pane_bttn) configure -image $img return } # toggle image mode # ----------------- set ori [$widgetCompounds(pane) cget -orient] if {$ori == "horizontal"} { set ori "vertical" set img $widgetCompounds(img_topbottom) } else { set ori "horizontal" set img $widgetCompounds(img_leftright) } $widgetCompounds(pane) configure -orient $ori $widgetCompounds(pane_bttn) configure -image $img my Zoom2Selection } OOD GetMaxAttributeString {lst} { set rstr "" foreach item $lst { set str [lindex $item 0] # don't forget to add: append str ": " if {$rstr == ""} {set rstr $str} if {[string length $str] > [string length $rstr]} {set rstr $str} } return $rstr } OOD AddTextTags {} { my variable widgetCompounds my variable tblwidget set txt $widgetCompounds(txtwidget) set lst [my cget -xtabheader] if {[llength $lst] == 0} { return } set attr_str [my GetMaxAttributeString $lst] # font metrics: # font measure font ?-displayof window? text # Measures the amount of space the string text would use in the # given font when displayed in window. # The return value is the total width in pixels of text. set margin [font measure APP_FONT_BIG_BOLD -displayof $txt $attr_str] # puts "--> $attr_str : $margin" # text widget tag definitions # --------------------------- $txt tag configure ATTR_NAME \ -font APP_FONT_STD_BOLD -spacing1 5 $txt tag configure ATTR_TXT0 \ -font APP_FONT_BIG_BOLD \ -foreground "DarkRed" $txt tag configure ATTR_TXT1 \ -font APP_FONT_STD_NORMAL \ -foreground "DarkBlue" -lmargin2 $margin } OOD Build {frm} { my variable widgetCompounds my variable tblwidget set f [ttk::frame $frm.bttn] pack $f -fill x -side top ttk::button $f.bttn \ -text "" -compound left \ -command "[namespace code {my TogglePaneOrientation}]" \ -style Toolbutton ttk::label $f.lbl \ -text "" -compound left \ -font APP_FONT_SMALL_NORMAL pack $f.bttn $f.lbl -side right -pady 5 set widgetCompounds(pane_bttn) $f.bttn set widgetCompounds(date) $f.lbl # status message # -------------- set f [ttk::frame $frm.status] pack $f -fill x -side bottom ttk::label $f.lbl \ -text "" \ -font widgetCompounds_FONT_SMALL_ITALIC pack $f.lbl -side right -pady 5 set widgetCompounds(status_msg) $f.lbl set f [ttk::frame $frm.tbl] pack $f -fill both -expand true -side bottom # note: ttk::panedwindow does not allow: # "configure -orient ..." (option is read-only ?!...) set pane [panedwindow $f.pane \ -orient $widgetCompounds(paneorient) \ -sashwidth 5 -opaqueresize true] $pane add [set pane_uppr [ttk::frame $frm.pane_uppr]] pack $pane -fill both -expand true $pane add [set pane_lowr [ttk::frame $frm.pane_lowr]] set widgetCompounds(pane) $pane bind $f.pane "[namespace code {my Zoom2Selection}]" bind $f.pane <3> "[namespace code {my TogglePaneOrientation}]" # ---------------------- # tablelist goes here... # ---------------------- tablelist::tablelist $pane_uppr.tbl \ -showseparators yes \ -selectmode single \ -labelcommand "::tablelist::sortByColumn" \ -stretch 2 \ -yscrollcommand "$pane_uppr.scrolly set" \ -stripebackground "#FDFEFE" set tblwidget $pane_uppr.tbl ttk::scrollbar $pane_uppr.scrolly \ -command "$pane_uppr.tbl yview" -orient vertical pack $pane_uppr.scrolly -side right -fill y pack $pane_uppr.tbl -side left -fill both -expand true autoscroll::autoscroll $pane_uppr.scrolly # ----------- # text-widget # ----------- text $pane_lowr.txt \ -wrap word -height 30 \ -yscrollcommand "$pane_lowr.scrolly set" set widgetCompounds(txtwidget) $pane_lowr.txt ttk::scrollbar $pane_lowr.scrolly \ -command "$pane_lowr.txt yview" -orient vertical pack $pane_lowr.scrolly -side right -fill y pack $pane_lowr.txt -side left -fill both -expand true autoscroll::autoscroll $pane_lowr.scrolly # retrieve option settings from ttk $widgetCompounds(txtwidget) configure \ -fg [ttk::style configure . -foreground] \ -bg [ttk::style configure . -background] $tblwidget configure \ -selectforeground [ttk::style configure . -selectforeground] \ -selectbackground [ttk::style configure . -selectbackground] # --------------------------- # initialization starts here: # --------------------------- my EnableMoveoverBindings my TogglePaneOrientation my GetTime } # --- # eof # --- ====== * ImageLib.tcl ====== # ImageLib.tcl --- # Automatically created by: CreateImageLib.tcl set images(img_unchecked) [image create photo -data { R0lGODlhDQANAPIFABxRgOLi3erq5vHx7/n5+QAAAAAAAAAAACH5BAEBAAUALAAAAAANAA0AAANk CAAAgAAAAAgQEYEhIjM4ABGBISIzOAMQgSEiM0hDAIEhIjM4RASAISIyOEREgCAiMzhERIQAIjI4 RESEBCAzOEREhEQAMjhERIREBDA4RESEREQAOENEhEREBAgAAIAAAAAICQA7 }] set images(img_checked) [image create photo -data { R0lGODlhDQANAPIGABxRgCGhIeLi3erq5vHx7/n5+AAAAAAAACH5BAEBAAYALAAAAAANAA0AAANk CAAAgAAAAAggIoIyM0RIACKCMjNESAQggjIzRBhVAIIjM0QYUQWAIjFEGBFVgDATQRgRVYUAMxEY EVWFBTBEGBFVhVUAREgVVYVVBUBIVVWFVVUASFRVhVVVBQgAAIAAAAAICQA7 }] set images(img_leftright) [image create photo -data { iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGOfPtRkwAACj1pQ0NQ aWNjAAB42p1TZ1RT6RY99970QkuIgJRLb1IVCCBSQouAVGmiEpIAoYQYEkDsiKjAiKIighUZFHHA 0RGQsSKKhUGx9wF5CCjj4Cg2VN4P3hp9s+a9N2/2r732OWed75x9PgBGYLBEmoWqAWRKFfKIAB88 Ni4eJ3cDClQggQOAQJgtC4n0jwIA4Pvx8OyIAB/4AgTgzW1AAABu2ASG4Tj8f1AXyuQKACQMAKaL xNlCAKQQADJyFTIFADIKAOykdJkCACUAAFseGxcPgGoBADtlkk8DAHbSJPcCALYoUyoCQKMAQCbK FIkA0A4AWJejFIsAsGAAKMqRiHMBsJsAYJKhzJQAYO8AgJ0pFmQDEBgAYKIQC1MBCPYAwJBHRfAA CDMBKIyUr3jSV1whzlMAAPCyZIvlkpRUBW4htMQdXF25eKA4N0OsUNiECYTpArkI52VlygTSxQCT MwMAgEZ2RIAPzvfjOTu4OjvbONo6fLWo/xr8i4iNi/+XP6/CAQEAhNP1RfuzvKwaAO4YALbxi5a0 HaBlDYDW/S+ayR4A1UKA5qtfzcPh+/HwVIVC5mZnl5ubaysRC22FqV/1+Z8JfwFf9bPl+/Hw39eD +4qTBcoMBR4R4IMLszKylHI8WyYQinGbPx7x3y7883dMixAni+ViqVCMR0vEuRJpCs7LkookCkmW FJdI/5OJf7PsD5i8awBg1X4G9kJbULvKBuyXLiCw6IAl7AIA5HffgqnREAYAMQaDk3cPADD5m/8d aBkAoNmSFBwAgBcRhQuV8pzJGAEAgAg0UAU2aIM+GIMF2IAjuIA7eIEfzIZQiII4WABCSIVMkEMu LIVVUAQlsBG2QhXshlqoh0Y4Ai1wAs7CBbgC1+AWPIBeGIDnMApvYBxBEDLCRFiINmKAmCLWiCPC RWYhfkgwEoHEIYlICiJFlMhSZDVSgpQjVchepB75HjmOnEUuIT3IPaQPGUZ+Qz6gGMpA2ageaoba oVzUGw1Co9D5aAq6CM1HC9ENaCVagx5Cm9Gz6BX0FtqLPkfHMMDoGAczxGwwLsbDQrF4LBmTY8ux YqwCq8EasTasE7uB9WIj2HsCicAi4AQbgjshkDCXICQsIiwnlBKqCAcIzYQOwg1CH2GU8JnIJOoS rYluRD4xlphCzCUWESuIdcRjxPPEW8QB4hsSicQhmZNcSIGkOFIaaQmplLST1EQ6Q+oh9ZPGyGSy Ntma7EEOJQvICnIReTv5EPk0+Tp5gPyOQqcYUBwp/pR4ipRSQKmgHKScolynDFLGqWpUU6obNZQq oi6mllFrqW3Uq9QB6jhNnWZO86BF0dJoq2iVtEbaedpD2is6nW5Ed6WH0yX0lfRK+mH6RXof/T1D g2HF4DESGErGBsZ+xhnGPcYrJpNpxvRixjMVzA3MeuY55mPmOxWWiq0KX0WkskKlWqVZ5brKC1Wq qqmqt+oC1XzVCtWjqldVR9SoamZqPDWB2nK1arXjanfUxtRZ6g7qoeqZ6qXqB9UvqQ9pkDXMNPw0 RBqFGvs0zmn0szCWMYvHErJWs2pZ51kDbBLbnM1np7FL2N+xu9mjmhqaMzSjNfM0qzVPavZyMI4Z h8/J4JRxjnBucz5M0ZviPUU8Zf2UxinXp7zVmqrlpSXWKtZq0rql9UEb1/bTTtfepN2i/UiHoGOl E66Tq7NL57zOyFT2VPepwqnFU49Mva+L6lrpRugu0d2n26U7pqevF6An09uud05vRJ+j76Wfpr9F /5T+sAHLYJaBxGCLwWmDZ7gm7o1n4JV4Bz5qqGsYaKg03GvYbThuZG4016jAqMnokTHNmGucbLzF uN141MTAJMRkqUmDyX1TqinXNNV0m2mn6Vszc7MYs7VmLWZD5lrmfPN88wbzhxZMC0+LRRY1Fjct SZZcy3TLnZbXrFArJ6tUq2qrq9aotbO1xHqndc804jTXadJpNdPu2DBsvG1ybBps+mw5tsG2BbYt ti/sTOzi7TbZddp9tneyz7CvtX/goOEw26HAoc3hN0crR6FjtePN6czp/tNXTG+d/nKG9QzxjF0z 7jqxnEKc1jq1O31ydnGWOzc6D7uYuCS67HC5w2Vzw7il3IuuRFcf1xWuJ1zfuzm7KdyOuP3qbuOe 7n7QfWim+UzxzNqZ/R5GHgKPvR69s/BZibP2zOr1NPQUeNZ4PvEy9hJ51XkNelt6p3kf8n7hY+8j 9znm85bnxlvGO+OL+Qb4Fvt2+2n4zfWr8nvsb+Sf4t/gPxrgFLAk4EwgMTAocFPgHb4eX8iv54/O dpm9bHZHECMoMqgq6EmwVbA8uC0EDZkdsjnk4RzTOdI5LaEQyg/dHPoozDxsUdiP4aTwsPDq8KcR DhFLIzojWZELIw9GvonyiSqLejDXYq5ybnu0anRCdH302xjfmPKY3li72GWxV+J04iRxrfHk+Oj4 uvixeX7zts4bSHBKKEq4Pd98ft78Swt0FmQsOLlQdaFg4dFEYmJM4sHEj4JQQY1gLImftCNpVMgT bhM+F3mJtoiGxR7icvFgskdyefJQikfK5pThVM/UitQRCU9SJXmZFpi2O+1temj6/vSJjJiMpkxK ZmLmcamGNF3akaWflZfVI7OWFcl6F7kt2rpoVB4kr8tGsudntyrYCpmiS2mhXKPsy5mVU53zLjc6 92ieep40r2ux1eL1iwfz/fO/XUJYIlzSvtRw6aqlfcu8l+1djixPWt6+wnhF4YqBlQErD6yirUpf 9VOBfUF5wevVMavbCvUKVxb2rwlY01CkUiQvurPWfe3udYR1knXd66ev377+c7Go+HKJfUlFycdS Yenlbxy+qfxmYkPyhu4y57JdG0kbpRtvb/LcdKBcvTy/vH9zyObmLfiW4i2vty7ceqliRsXubbRt ym29lcGVrdtNtm/c/rEqtepWtU910w7dHet3vN0p2nl9l9euxt16u0t2f9gj2XN3b8De5hqzmop9 pH05+57WRtd2fsv9tr5Op66k7tN+6f7eAxEHOupd6usP6h4sa0AblA3DhxIOXfvO97vWRpvGvU2c ppLDcFh5+Nn3id/fPhJ0pP0o92jjD6Y/7DjGOlbcjDQvbh5tSW3pbY1r7Tk++3h7m3vbsR9tf9x/ wvBE9UnNk2WnaKcKT02czj89dkZ2ZuRsytn+9oXtD87FnrvZEd7RfT7o/MUL/hfOdXp3nr7ocfHE JbdLxy9zL7dccb7S3OXUdewnp5+OdTt3N191udp6zfVaW8/MnlPXPa+fveF748JN/s0rt+bc6rk9 9/bdOwl3eu+K7g7dy7j38n7O/fEHKx8SHxY/UntU8Vj3cc3Plj839Tr3nuzz7et6EvnkQb+w//k/ sv/xcaDwKfNpxaDBYP2Q49CJYf/ha8/mPRt4Lns+PlL0i/ovO15YvPjhV69fu0ZjRwdeyl9O/Fb6 SvvV/tczXrePhY09fpP5Zvxt8Tvtdwfec993foj5MDie+5H8sfKT5ae2z0GfH05kTkz8EwOY8/wl YzOiAAAAIGNIUk0AAHolAACAgwAA+f8AAIDpAAB1MAAA6mAAADqYAAAXb5JfxUYAAAAGYktHRAAA AAAAAPlDu38AAAAJcEhZcwAACxMAAAsTAQCanBgAAAAJdnBBZwAAABAAAAAQAFzGrcMAAAGUSURB VDjLpZPLalRBEIa/uvSZk8GoG13oQiRbd0LiRvA5fKC8gBvXPoqoEARB3JpFFgZFFB285JzTXeVi MiYamYXT0DRd1f1T9fXfkplsMnz/0ZPHw8l4o9aWLYIWQUSezgBAVVARRIWuOKaKm0kIx16H8eGD +3vbJ8PEME4MY2WaJsapMdWGAMWN4oYX5+r2nH5WmHWF5wevvvj1K531+Z2+g2aN1gXT1Ahg8XXg 5/CDy7M5W33PfF7ot5KuE8yCm9cuue/s3PbdvV1abYhAiKAJpTgvXr4mIrl39w5Ta5goZgoimCqL byfuqoqpYp1eABSReCm4O+7+T4i6BjApibD+ldYLJCDy/wI0kNxEwCAk1hwQfOXEiLNeI8BdyBQI LuRhaa7IxDmFlBmna7IULTiJigL5O3/GZxn31YVVJef35orpUjwikHNAMxMycREVEUHV/qAvIpSu pyuOiC0N9FcLoooff/j45umzg1vDOEZkUmtlGiu1VT59XmBmHB6+xcxxM1QNVWHWFT169/5INv3O vwAQJMu2Z9D/4wAAACV0RVh0Y3JlYXRlLWRhdGUAMjAwOS0xMS0yOFQxNzoxODoyOC0wNzowMDGR siwAAAAldEVYdGRhdGU6Y3JlYXRlADIwMTAtMDItMjBUMjM6MjQ6MjAtMDc6MDDeeaT4AAAAJXRF WHRkYXRlOm1vZGlmeQAyMDEwLTAxLTExVDA4OjQyOjQzLTA3OjAw5QuC6AAAADV0RVh0TGljZW5z ZQBodHRwOi8vY3JlYXRpdmVjb21tb25zLm9yZy9saWNlbnNlcy9MR1BMLzIuMS87wbQYAAAAJXRF WHRtb2RpZnktZGF0ZQAyMDA5LTExLTI4VDE0OjMxOjI4LTA3OjAwd5M63QAAABZ0RVh0U291cmNl AENyeXN0YWwgUHJvamVjdOvj5IsAAAAndEVYdFNvdXJjZV9VUkwAaHR0cDovL2V2ZXJhbGRvLmNv bS9jcnlzdGFsL6WRk1sAAAAASUVORK5CYII= }] set images(img_topbottom) [image create photo -data { iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QAAAAAAAD5Q7t/AAAACXBI WXMAAABIAAAASABGyWs+AAAACXZwQWcAAAAQAAAAEABcxq3DAAABLklEQVQ4y62Tr04EQQyHv850 dw+SC0hyCad4BxTheA0eCE2CQaDAIXgADCAQGAgeTZDI292ZFrF7wCH4c0czzaSiv/z6dUbcnWVC D45Oj+tpM0opezYjm2HmfRoAIQhBBAlCWSgxBDRGMeFZU93sT3a2h9O6pW5a6ibRti1Nm2lTRoBC I4VGtFDWh6sMqoKqLLi9u3/VSklbozWQQAiCiHQ3AenrLgGkP4Jq5OExtlqUJZvj8ULzx6iEJRkS lmv/BwEFuLq+AQnY5xW60W3R38EGEWQGG/8Q2Jvs8vVBSYf923g6u0DplRYRcPfOgXtnew7OL+lo L8XMyZ8hClLklMhmnUQ/iqr+2CwiaKyqy8OT842UM9kcy4a5Y7kTijHi2FxdamSlGtB4epFlv/Mb xG2MLzGlDgAAAAAldEVYdGNyZWF0ZS1kYXRlADIwMDktMTEtMjhUMTc6MTg6MjgtMDc6MDAxkbIs AAAAJXRFWHRkYXRlOmNyZWF0ZQAyMDEwLTAyLTIwVDIzOjI0OjIwLTA3OjAw3nmk+AAAACV0RVh0 ZGF0ZTptb2RpZnkAMjAxMC0wMS0xMVQwODo0Mjo1MS0wNzowML4+k18AAAA1dEVYdExpY2Vuc2UA aHR0cDovL2NyZWF0aXZlY29tbW9ucy5vcmcvbGljZW5zZXMvTEdQTC8yLjEvO8G0GAAAACV0RVh0 bW9kaWZ5LWRhdGUAMjAwOS0xMS0yOFQxNDozMTozMS0wNzowMC6hf5AAAAAWdEVYdFNvdXJjZQBD cnlzdGFsIFByb2plY3Tr4+SLAAAAJ3RFWHRTb3VyY2VfVVJMAGh0dHA6Ly9ldmVyYWxkby5jb20v Y3J5c3RhbC+lkZNbAAAAAElFTkSuQmCC }] ====== * tablelistbrowser_demo.tcl ====== # ----------------------------------------------------------------------------- # tablelistbrowser.tcl --- # ----------------------------------------------------------------------------- # (c) 2016, Johann Oberdorfer - Engineering Support | CAD | Software # johann.oberdorfer [at] gmail.com # www.johann-oberdorfer.eu # ----------------------------------------------------------------------------- # This source file is distributed under the BSD license. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # See the BSD License for more details. # ----------------------------------------------------------------------------- # Purpose: # A TclOO class template to extend tablelist functionality. # Might be usefull as a starting point. # ----------------------------------------------------------------------------- # TclOO naming conventions: # public methods - starts with lower case declaration names, whereas # private methods - starts with uppercase naming, so we are going to use CamelCase ... # ----------------------------------------------------------------------------- # for development: try to find autoscroll, etc ... set this_file [file normalize [file dirname [info script]]] # where to find required packages... set auto_path [linsert $auto_path 0 [file join $this_file ".."]] package require Tk package require TclOO package require autoscroll package require tablelist_tile package require tablelistbrowser set fnames [font names] set fsize 10 set ffamily "Courier" font create APP_FONT_STD_NORMAL -family $ffamily -size $fsize -weight normal font create APP_FONT_STD_BOLD -family $ffamily -size $fsize -weight bold font create APP_FONT_SMALL_NORMAL -family $ffamily -size [expr {$fsize - 2}] -weight normal font create APP_FONT_BIG_BOLD -family $ffamily -size [expr {$fsize + 0}] -weight bold # --------- # demo code # --------- catch {console show} set t [tablelistbrowser::tablelistbrowser .t \ -showseparators yes \ -selectmode single \ -labelcommand "tablelist::sortByColumn"] pack $t -fill both -expand true # create some random test data... set demo "info_procs" switch -- $demo { "random" { set header \ {{"ID" 10 left} {"Category" 22 left} {"test-column" 16 left} {"Hello\\nWorld" 10 left} {"test" "hidden" center} {"last\\ncolumn" 10 left}} $t configure \ -xtabheader $header set data_list {} set cnt 0 while {$cnt < 40} { lappend data_list \ [list $cnt \ [expr {$cnt +1}] [expr {$cnt +2}] \ [expr {$cnt +3}] [expr {$cnt +4}] \ [expr {$cnt +5}]] incr cnt } foreach item $data_list { $t insert end $item } } "info_procs" { set header \ {{"ID" 10 left} {"Info_Procs" 20 left} {"Body" hidden left}} $t configure \ -xtabheader $header \ -snipstring "..." set data_list {} set cnt 0 foreach p [lsort -dictionary [info procs]] { # set body [string map {"\n" " "} [info body $p]] set row [list $cnt $p [string trim [info body $p]]] $t insert end $row incr cnt } } } # --------------------- # object introspection: # --------------------- # puts [winfo class $t] # puts [$t configure] # catch { [$t blabla 1] } msg # puts $msg # return # puts [$t cget -xtabheader] # how to access the tablelist widget: # [$t getwidgetpath] configure -columns \ # "12 Test1 left 12 Test2 left" # $t selection clear 0 end # puts [$t curselection] # $t modifyColumnImage "dummy,0" "init" ====== * pkgIndex.tcl ====== # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. package ifneeded tablelistbrowser 0.1 [list source [file join $dir tablelistbrowser.tcl]] ====== <> TclOO Megawidgets