mclistbox.wgt

一个跨平台的TCL/TK可视开发环境类似VC. TCL/TK是一个跨平台的脚本语言.

##############################################################################
#
# Visual TCL - A cross-platform application development environment
#
# Copyright (C) 2001 Christian Gavin
#
# Description file for Multicolumn listbox
# Copyright (C) 1999 Bryan Oakley for Multicolumn listbox code (see below).
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# 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
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

##############################################################################
#

Class         Mclistbox
Lib           vtcl

CreateCmd     ::mclistbox::mclistbox
Icon          icon_mclistbox.gif
Balloon       multicolumn listbox
DumpChildren  no
MegaWidget    yes
Resizable     both
TreeLabel     Multicolumn Listbox
AliasPrefix   Mclistbox
ResizeCmd     vTcl::widgets::vtcl::mclistbox::resizeCmd
InsertCmd     vTcl::widgets::vtcl::mclistbox::insertCmd
DumpCmd       vTcl::widgets::vtcl::mclistbox::dumpCmd
GetImagesCmd  vTcl::widgets::vtcl::mclistbox::getImagesCmd
GetFontsCmd   vTcl::widgets::vtcl::mclistbox::getFontsCmd

Function      "Edit Columns..." vTcl::widgets::vtcl::mclistbox::editColumns

lappend vTcl(classes) MclistboxColumn

## New options for this widget
NewOption -columnborderwidth {Col Brdr Width}   type
NewOption -columnrelief      {Col Relief}       relief
NewOption -fillcolumn        {Fill Col}         type
NewOption -labelanchor       {Label Anchor}     choice  {n ne e se s sw w nw center}
NewOption -labelbackground   {Label Bkgnd}      color {} Colors
NewOption -labelborderwidth  {Label Brdr Width} type
NewOption -labelforeground   {Label Foregnd}    color {} Colors
NewOption -labelheight       {Label Height}     type
NewOption -labelrelief       {Label Relief}     relief
NewOption -labels            {Show Labels}      boolean  {0 1}
NewOption -resizablecolumns  {Resizable Cols}   boolean  {0 1}

## New options for columns
NewOption -position          {Col Position}	type
NewOption -resizable         {Col Resizable}    boolean  {0 1}
NewOption -visible           {Col Visible}      boolean  {0 1}

## Multicolumn listbox support
NewOption -_mclistbox_columns  "columns"  combobox
ClassOption -_mclistbox_columns
OptionConfigCmd -_mclistbox_columns     config     vTcl::widgets::vtcl::mclistbox::config_columns
OptionConfigCmd -_mclistbox_columns     update     vTcl::widgets::vtcl::mclistbox::update_columns
OptionConfigCmd -_mclistbox_columns     get        vTcl::widgets::vtcl::mclistbox::get_columns
OptionConfigCmd -_mclistbox_columns     select     vTcl::widgets::vtcl::mclistbox::select_column
OptionConfigCmd -_mclistbox_columns     edit       vTcl::itemEdit::edit
OptionConfigCmd -_mclistbox_columns     editArg    vTcl::widgets::vtcl::mclistbox::edit

## For saving images
TranslateOption -labelimage vTcl:image:translate
NoEncaseOption  -labelimage 1

namespace eval ::vTcl::widgets::vtcl::mclistbox::edit {

    proc getTitle {target} {
        return "Edit columns for $target"
    }

    proc getLabelOption {} {
        return -label
    }

    proc getItems {target} {
        ## first item in the list is the current index
        set names [$target column names]
        set values 0
        foreach name $names {
            set label_opt [$target column cget $name -label]
            lappend values $label_opt
        }
        return $values
    }

    proc addItem {target} {
        set pages [$target column names]
        set index 0
        ## repeat until we find an unused page number
        while {1} {
            incr index
            set newpage "col$index"
            if {[lsearch -exact $pages $newpage] == -1} break
        }
        $target column add $newpage -label "Column $index"
        return "Column $index"
    }

    proc removeItem {target index} {
        set columns [$target column names]
        set column  [lindex $columns $index]
        $target column delete $column
    }

    proc moveUpOrDown {target index direction} {
        set columns [$target column names]
        set length [llength $columns]
        set i 0
        set offset(up) -1
        set offset(down) 1
        set k [expr ($index + $offset($direction)) % $length]
        ## here we assign positions to columns
        foreach column $columns {
            if {$i == $index} {
                $target column configure $column -position $k
            } elseif {$i == $k} {
                $target column configure $column -position $index
            } else {
                $target column configure $column -position $i
            }
            incr i
        }
        update idletasks
        ## do it one more time
        set columns [$target column names]
        foreach column $columns {
            set position [$target column cget $column -position]
            $target column configure $column -position $position
        }
    }

    proc itemConfigure {target index args} {
        set columns [$target column names]
        set column  [lindex $columns $index]
        if {$args == ""} {
            return [$target column configure $column]
        } else {
            eval $target column configure $column $args
        }
    }
}

namespace eval ::vTcl::widgets::vtcl::mclistbox {

    proc editColumns {} {
        set target $::vTcl(w,widget)
	::vTcl::itemEdit::edit $target vTcl::widgets::vtcl::mclistbox::edit
    }

    proc get_columns {target} {
    }

    proc update_columns {target var} {
        ## there is a trace on var to update the combobox
        ## first item in the list is the current index
        set names [$target column names]
        set values 0
        foreach name $names {
            set label_opt [$target column cget $name -label]
            lappend values $label_opt
        }

        ## this will trigger the trace
        set ::$var $values
    }

    proc config_columns {target var} {
    }

    proc select_column {target index} {
    }

    proc insertCmd {target} {
        $target configure -height 0
        $target column add col1 -label {Column 1}
        $target column add col2 -label {Column 2}
        $target insert end {{line1 col1} {line1 col2}}
        $target insert end {{line2 col1} {line2 col2}}
    }

    proc dumpCmd {target basename} {
        set result [vTcl:dump_widget_opt $target $basename]
        set names [$target column names]
        set index 1
        foreach name $names {
            set conf [$target column configure $name]
            set pairs [vTcl:get_subopts_special $conf $target]
            append result "$::vTcl(tab)$basename column add col$index \\\n"
            append result "[vTcl:clean_pairs $pairs]\n"
            incr index
        }
        return $result
    }

    proc resizeCmd {target w h} {
        $target configure -width $w -height $h
    }

    proc getImagesCmd {target} {
        set result [$target cget -labelimage]
        set names [$target column names]
        foreach name $names {
            set image [$target column cget $name -image]
            if {$image != ""} {
                lappend result $image
            }
        }
        return $result
    }

    proc getFontsCmd {target} {
        set result [$target cget -labelfont]
        set names [$target column names]
        foreach name $names {
            set image [$target column cget $name -font]
            if {$image != ""} {
                lappend result $image
            }
        }
        return $result
    }
}

# Routines that need to be exported to a saved project

Export __mclistbox_Setup
Export ::mclistbox::FindResizableNeighbor
Export ::mclistbox::WidgetProc
Export ::mclistbox::SetClassBindings
Export ::mclistbox::NewColumn
Export ::mclistbox::MassageIndex
Export ::mclistbox::Configure
Export ::mclistbox::ItemConfigure
Export ::mclistbox::LabelEvent
Export ::mclistbox::SetBindings
Export ::mclistbox::AdjustColumns
Export ::mclistbox::Init
Export ::mclistbox::Insert
Export ::mclistbox::Column-configure
Export ::mclistbox::ColumnIsHidden
Export ::mclistbox::InvalidateScrollbars
Export ::mclistbox::Build
Export ::mclistbox::DestroyHandler
Export ::mclistbox::CheckColumnID
Export ::mclistbox::convert
Export ::mclistbox::UpdateScrollbars
Export ::mclistbox::ResizeEvent
Export ::mclistbox::SelectionHandler
Export ::mclistbox::Column-add
Export ::mclistbox::HumanizeList
Export ::mclistbox::WidgetProc-get
Export ::mclistbox::mclistbox
Export ::mclistbox::Canonize

proc __mclistbox_Setup {} {

    namespace eval ::mclistbox {

        # this is the public interface
        namespace export mclistbox

        # these contain references to available options
        variable widgetOptions
        variable columnOptions
	variable itemConfigureOptions

        # these contain references to available commands and subcommands
        variable widgetCommands
        variable columnCommands
        variable labelCommands
    }
}

__mclistbox_Setup

# Copyright (c) 1999, Bryan Oakley
# All Rights Reserved
#
# Bryan Oakley
# [e-mail]
#
# mclistbox v1.02 March 30, 1999
#
# a multicolumn listbox written in pure tcl
#
# this code is freely distributable without restriction, but is
# provided as-is with no waranty expressed or implied.
#
# basic usage:
#    
#    mclistbox::mclistbox .listbox
#    .listbox column add col1 -label "Column 1"
#    .listbox column add col2 -label "Column 2"
#    .listbox insert end [list "some stuff" "some more stuff"]
#    .listbox insert end [list "a second row of stuff" "blah blah blah"]
#
# see the documentation for more, uh, documentation.
#
# Something to think about: implement a "-optimize" option, with two 
# values: speed and memory. If set to speed, keep a copy of the data
# in our hidden listbox so retrieval of data doesn't require us to
# do all the getting and splitting and so forth. If set to "memory",
# bag saving a duplicate copy of the data, which means data retrieval
# will be slower, but memory requirements will be reduced. 

# package require Tk 8.0
# package provide mclistbox 1.02
#
# namespace eval ::mclistbox {
#
#    # this is the public interface
#    namespace export mclistbox
#
#    # these contain references to available options
#    variable widgetOptions
#    variable columnOptions
#
#    # these contain references to available commands and subcommands
#    variable widgetCommands
#    variable columnCommands
#    variable labelCommands
# }

# ::mclistbox::Init --
#
#     Initialize the global (well, namespace) variables. This should
#     only be called once, immediately prior to creating the first
#     instance of the widget
#
# Results:
#
#     All state variables are set to their default values; all of 
#     the option database entries will exist.
#
# Returns:
# 
#     empty string

proc ::mclistbox::Init {} {
    variable widgetOptions
    variable columnOptions
    variable itemConfigureOptions
    variable widgetCommands
    variable columnCommands
    variable labelCommands

    # here we match up command line options with option database names
    # and classes. As it turns out, this is a handy reference of all of the
    # available options. Note that if an item has a value with only one
    # item (like -bd, for example) it is a synonym and the value is the
    # actual item.

    array set widgetOptions [list \
	    -background          {background          Background} \
	    -bd                  -borderwidth \
	    -bg                  -background \
	    -borderwidth         {borderWidth         BorderWidth} \
	    -columnbd            -columnborderwidth \
	    -columnborderwidth   {columnBorderWidth   BorderWidth} \
	    -columnrelief        {columnRelief        Relief} \
	    -cursor              {cursor              Cursor} \
	    -exportselection     {exportSelection     ExportSelection} \
	    -fg                  -foreground \
	    -fillcolumn          {fillColumn          FillColumn} \
	    -font                {font                Font} \
	    -foreground          {foreground          Foreground} \
	    -height              {height              Height} \
	    -highlightbackground {highlightBackground HighlightBackground} \
	    -highlightcolor      {highlightColor      HighlightColor} \
	    -highlightthickness  {highlightThickness  HighlightThickness} \
	    -labelanchor         {labelAnchor         Anchor} \
	    -labelbackground     {labelBackground     Background} \
	    -labelbd             -labelborderwidth \
	    -labelbg             -labelbackground \
	    -labelborderwidth    {labelBorderWidth    BorderWidth} \
	    -labelfg             -labelforeground \
	    -labelfont           {labelFont           Font} \
	    -labelforeground     {labelForeground     Foreground} \
	    -labelheight         {labelHeight         Height} \
	    -labelimage          {labelImage          Image} \
	    -labelrelief         {labelRelief         Relief} \
	    -labels              {labels              Labels} \
	    -relief              {relief              Relief} \
	    -resizablecolumns    {resizableColumns    ResizableColumns} \
	    -selectbackground    {selectBackground    Foreground} \
	    -selectborderwidth   {selectBorderWidth   BorderWidth} \
	    -selectcommand       {selectCommand       Command} \
	    -selectforeground    {selectForeground    Background} \
	    -selectmode          {selectMode          SelectMode} \
	    -setgrid             {setGrid             SetGrid} \
	    -takefocus           {takeFocus           TakeFocus} \
	    -width               {width               Width} \
	    -xscrollcommand      {xScrollCommand      ScrollCommand} \
	    -yscrollcommand      {yScrollCommand      ScrollCommand} \
	    ]

    # and likewise for column-specific stuff. 
    array set columnOptions [list \
	    -background         {background           Background} \
	    -bitmap		{bitmap               Bitmap} \
	    -font               {font                 Font} \