combobox.wgt

来自「一个跨平台的TCL/TK可视开发环境类似VC. TCL/TK是一个跨平台的脚本」· WGT 代码 · 共 2,104 行 · 第 1/5 页

Class         Combobox2
Lib           vtcl

CreateCmd     ::combobox2::combobox2
Icon          icon_combobox.gif
Balloon       vTcl combo box
DumpChildren  no
MegaWidget    yes
Resizable     horizontal
TreeLabel     @vTcl::widgets::vtcl::combobox2::getWidgetTreeLabel
AliasPrefix   Combo
ResizeCmd     vTcl::widgets::vtcl::combobox2::resizeCmd
InsertCmd     vTcl::widgets::vtcl::combobox2::insertCmd

# New options for this widget
NewOption -commandstate    "Command State"  choice {normal disabled}
NewOption -maxheight       "Max Height"     type

namespace eval vTcl::widgets::vtcl::combobox2 {

    proc resizeCmd {widget w h} {
        $widget configure -width $w
    }

    proc insertCmd {target} {
        set last [lindex [split $target .] end]
        set last [vTcl:rename $last]
        set name "[winfo toplevel $target]::$last"

        $target configure -textvariable $name
    }

    proc getWidgetTreeLabel {target} {
        set var [$target cget -textvariable]
	if {$var != ""} {
	    return "Combo Box TEXTVAR=$var"
	} else {
	    return "Combo Box"
	}
    }
}

# Routines that need to be exported to a saved project

Export __combobox2_Setup
Export ::combobox2::combobox2
Export ::combobox2::Init
Export ::combobox2::SetClassBindings
Export ::combobox2::SetBindings
Export ::combobox2::Build
Export ::combobox2::HandleEvent
Export ::combobox2::DestroyHandler
Export ::combobox2::Find
Export ::combobox2::Select
Export ::combobox2::HandleScrollbar
Export ::combobox2::ComputeGeometry
Export ::combobox2::DoInternalWidgetCommand
Export ::combobox2::WidgetProc
Export ::combobox2::Configure
Export ::combobox2::VTrace
Export ::combobox2::SetValue
Export ::combobox2::CallCommand
Export ::combobox2::GetBoolean
Export ::combobox2::convert
Export ::combobox2::Canonize
Export ::combobox2::HumanizeList
Export ::combobox2::tkTabToWindow
Export ::combobox2::tkCancelRepeat

proc __combobox2_Setup {} {

    namespace eval ::combobox2 {

        # this is the public interface
        namespace export combobox2

        # these contain references to available options
        variable widgetOptions

        # these contain references to available commands and subcommands
        variable widgetCommands
        variable scanCommands
        variable listCommands
    }
}

__combobox2_Setup

# Copyright (c) 1998-1999, Bryan Oakley
# All Rights Reservered
#
# Bryan Oakley
# [e-mail]
#
# combobox v2.0b2 April 14, 1999
#
# a combobox / dropdown listbox (pick your favorite name) widget
# written in pure tcl
#
# this code is freely distributable without restriction, but is
# provided as-is with no waranty expressed or implied.
#
# thanks to the following people who provided beta test support or
# patches to the code (in no particular order):
#
# Scott Beasley     Alexandre Ferrieux      Todd Helfter
# Matt Gushee       Laurent Duperval        John Jackson
# Fred Rapp         Christopher Nelson
# Eric Galluzzo     Jean-Francois Moine

# A special thanks to Martin M. Hunt who provided several good ideas,
# and always with a patch to implement them. Jean-Francois Moine,
# Todd Helfter and John Jackson were also kind enough to send in some
# code patches.

# package require Tk 8.0
# package provide combobox 2.0
#
# namespace eval ::combobox {
#
#    # this is the public interface
#    namespace export combobox
#
#    # these contain references to available options
#    variable widgetOptions
#
#    # these contain references to available commands and subcommands
#    variable widgetCommands
#    variable scanCommands
#    variable listCommands
#
# }

# ::combobox2::combobox2 --
#
#     This is the command that gets exported. It creates a new
#     combobox2 widget.
#
# Arguments:
#
#     w        path of new widget to create
#     args     additional option/value pairs (eg: -background white, etc.)
#
# Results:
#
#     It creates the widget and sets up all of the default bindings
#
# Returns:
#
#     The name of the newly create widget

proc ::combobox2::combobox2 {w args} {
    variable widgetOptions
    variable widgetCommands
    variable scanCommands
    variable listCommands

    # perform a one time initialization
    if {![info exists widgetOptions]} {
	__combobox2_Setup
        Init
    }

    # build it...
    eval Build $w $args

    # set some bindings...
    SetBindings $w

    # and we are done!
    return $w
}


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

proc ::combobox2::Init {} {
    variable widgetOptions
    variable widgetCommands
    variable scanCommands
    variable listCommands
    variable defaultEntryCursor

    array set widgetOptions [list \
	    -background          {background          Background} \
	    -bd                  -borderwidth \
	    -bg                  -background \
	    -borderwidth         {borderWidth         BorderWidth} \
	    -command             {command             Command} \
	    -commandstate        {commandState        State} \
	    -cursor              {cursor              Cursor} \
	    -editable            {editable            Editable} \
	    -fg                  -foreground \
	    -font                {font                Font} \
	    -foreground          {foreground          Foreground} \
	    -height              {height              Height} \
	    -highlightbackground {highlightBackground HighlightBackground} \
	    -highlightcolor      {highlightColor      HighlightColor} \
	    -highlightthickness  {highlightThickness  HighlightThickness} \
	    -image               {image               Image} \
	    -maxheight           {maxHeight           Height} \
	    -relief              {relief              Relief} \
	    -selectbackground    {selectBackground    Foreground} \
	    -selectborderwidth   {selectBorderWidth   BorderWidth} \
	    -selectforeground    {selectForeground    Background} \
	    -state               {state               State} \
	    -takefocus           {takeFocus           TakeFocus} \
	    -textvariable        {textVariable        Variable} \
	    -value               {value               Value} \
	    -width               {width               Width} \
	    -xscrollcommand      {xScrollCommand      ScrollCommand} \
    ]


    set widgetCommands [list \
	    bbox      cget     configure    curselection \
	    delete    get      icursor      index        \
	    insert    list     scan         selection    \
	    xview     select   toggle       open         \
            close \
    ]

    set listCommands [list \
	    delete       get      \
            index        insert       size \
    ]

    set scanCommands [list mark dragto]

    # why check for the Tk package? This lets us be sourced into 
    # an interpreter that doesn't have Tk loaded, such as the slave
    # interpreter used by pkg_mkIndex. In theory it should have no
    # side effects when run
    if {[lsearch -exact [package names] "Tk"] != -1} {

	##################################################################
	#- this initializes the option database. Kinda gross, but it works
	#- (I think). 
	##################################################################

	# the image used for the button...
	if {$::tcl_platform(platform) == "windows"} {
	    image create bitmap ::combobox2::bimage -data {
		#define down_arrow_width 12
		#define down_arrow_height 12
		static char down_arrow_bits[] = {
		    0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
		    0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0,
		    0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00;
		}
	    }
	} else {
	    image create bitmap ::combobox2::bimage -data  {
		#define down_arrow_width 15
		#define down_arrow_height 15
		static char down_arrow_bits[] = {
		    0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80,
		    0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83,
		    0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80,
		    0x00,0x80,0x00,0x80,0x00,0x80
		}
	    }
	}

	# compute a widget name we can use to create a temporary widget
	set tmpWidget ".__tmp__"
	set count 0
	while {[winfo exists $tmpWidget] == 1} {
	    set tmpWidget ".__tmp__$count"
	    incr count
	}

	# get the scrollbar width. Because we try to be clever and draw our
	# own button instead of using a tk widget, we need to know what size
	# button to create. This little hack tells us the width of a scroll
	# bar.
	#
	# NB: we need to be sure and pick a window  that doesn't already
	# exist... 
	scrollbar $tmpWidget
	set sb_width [winfo reqwidth $tmpWidget]
	destroy $tmpWidget

	# steal options from the entry widget
	# we want darn near all options, so we'll go ahead and do
	# them all. No harm done in adding the one or two that we
	# don't use.
	entry $tmpWidget 
	foreach foo [$tmpWidget configure] {
	    # the cursor option is special, so we'll save it in
	    # a special way
	    if {[lindex $foo 0] == "-cursor"} {
		set defaultEntryCursor [lindex $foo 4]
	    }
	    if {[llength $foo] == 5} {
		set option [lindex $foo 1]
		set value [lindex $foo 4]
		option add *Combobox2.$option $value widgetDefault

		# these options also apply to the dropdown listbox
		if {[string compare $option "foreground"] == 0 \
			|| [string compare $option "background"] == 0 \
			|| [string compare $option "font"] == 0} {
		    option add *Combobox2*ComboboxListbox.$option $value \
			    widgetDefault
		}
	    }
	}
	destroy $tmpWidget

	# these are unique to us...
	option add *Combobox2.cursor              {}
	option add *Combobox2.commandState        normal widgetDefault
	option add *Combobox2.editable            1      widgetDefault
	option add *Combobox2.maxHeight           10     widgetDefault
	option add *Combobox2.height              0
    }

    # set class bindings
    SetClassBindings
}

## these procs were moved to the tk namespace in 8.4
proc ::combobox2::tkTabToWindow {w} {
    global tk_version
    if {$tk_version >= 8.4} {
        ::tk::TabToWindow $w
    } else {
        ::tkTabToWindow $w
    }
}

proc ::combobox2::tkCancelRepeat {} {
    global tk_version
    if {$tk_version >= 8.4} {
        ::tk::CancelRepeat
    } else {
        ::tkCancelRepeat
    }
}

# ::combobox2::SetClassBindings --
#
#    Sets up the default bindings for the widget class
#
#    this proc exists since it's The Right Thing To Do, but
#    I haven't had the time to figure out how to do all the
#    binding stuff on a class level. The main problem is that
#    the entry widget must have focus for the insertion cursor
#    to be visible. So, I either have to have the entry widget
#    have the Combobox2 bindtag, or do some fancy juggling of
#    events or some such. What a pain.
#
# Arguments:
#
#    none
#
# Returns:
#
#    empty string

proc ::combobox2::SetClassBindings {} {

    # make sure we clean up after ourselves...
    bind Combobox2 <Destroy> [list ::combobox2::DestroyHandler %W]

    # this will (hopefully) close (and lose the grab on) the
    # listbox if the user clicks anywhere outside of it. Note
    # that on Windows, you can click on some other app and
    # the listbox will still be there, because tcl won't see
    # that button click
    set this {[::combobox2::convert %W -W]}
    bind Combobox2 <Any-ButtonPress>   "$this close"
    bind Combobox2 <Any-ButtonRelease> "$this close"

    # this helps (but doesn't fully solve) focus issues. The general
    # idea is, whenever the frame gets focus it gets passed on to
    # the entry widget
    bind Combobox2 <FocusIn> {::combobox2::tkTabToWindow [::combobox2::convert %W -W].entry}

    # this closes the listbox if we get hidden
    bind Combobox2 <Unmap> {[::combobox2::convert %W -W] close}

    return ""
}

# ::combobox2::SetBindings --
#
#    here's where we do most of the binding foo. I think there's probably
#    a few bindings I ought to add that I just haven't thought
#    about...
#
#    I'm not convinced these are the proper bindings. Ideally all
#    bindings should be on "Combobox2", but because of my juggling of
#    bindtags I'm not convinced thats what I want to do. But, it all
#    seems to work, its just not as robust as it could be.
#
# Arguments:
#
#    w    widget pathname
#
# Returns:
#
#    empty string