compound_container.tcl

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

catch {
   eval set S $\:\:$N\:\:state
}

if {$S == "mouse_up"} return

if {$button_X <= $X &&
    $button_X + $button_width >= $X &&
    $button_Y <= $Y &&
    $button_Y + $button_height >= $Y } {
    
   ::bitmapbutton::show_state $W sunken

} else {

   ::bitmapbutton::show_state $W raised
}
}
}
#############################################################################
## Procedure:  ::bitmapbutton::mouse_up

namespace eval ::bitmapbutton {
proc mouse_up {W X Y} {
set button_X [winfo rootx $W]
set button_Y [winfo rooty $W]
set button_width [winfo width $W]
set button_height [winfo height $W]

::bitmapbutton::show_state $W raised

set N [vTcl:rename $W]
set S ""
catch {
   eval set S $\:\:$N\:\:state
}

if {$S == "mouse_down" } {

    set ::${N}::state "mouse_up"

    ## command triggered ?
    if {$button_X <= $X &&
        $button_X + $button_width >= $X &&
        $button_Y <= $Y &&
        $button_Y + $button_height >= $Y } {
        
        set ::${N}::W $W
        namespace eval ::${N} {
            variable command
            variable W
            if {[info exists command] && $command != ""} {
                vTcl:DoCmdOption $W $command
            }
        }
    }
}
}
}
#############################################################################
## Procedure:  ::bitmapbutton::set_command

namespace eval ::bitmapbutton {
proc set_command {W cmd} {
global widget

set N [vTcl:rename $W]
namespace eval ::${N} {}
set ::${N}::command $cmd
}
}
#############################################################################
## Procedure:  ::bitmapbutton::show_state

namespace eval ::bitmapbutton {
proc show_state {W S} {
global widget

set upframe    $W.upframe
set downframe  $W.downframe
set leftframe  $W.centerframe.leftframe
set rightframe $W.centerframe.rightframe

switch $S {

   sunken {
     $W configure -relief sunken
     $upframe    configure -height 4
     $leftframe  configure -width 4
     $rightframe configure -width 1
     $downframe  configure -height 1
   }

   raised {
     $W configure -relief raised
     $upframe configure -height 3
     $leftframe configure -width 3
     $rightframe configure -width 2
     $downframe configure -height 2
   }
}
}
}
#############################################################################
## Procedure:  main

proc ::main {argc argv} {}

#############################################################################
## Initialization Procedure:  init

proc ::init {argc argv} {}

init $argc $argv

#################################
# VTCL GENERATED GUI PROCEDURES
#

proc vTclWindow. {base} {
    if {$base == ""} {
        set base .
    }
    ###################
    # CREATING WIDGETS
    ###################
    wm focusmodel $top passive
    wm geometry $top 200x200+132+150; update
    wm maxsize $top 1284 1006
    wm minsize $top 111 1
    wm overrideredirect $top 0
    wm resizable $top 1 1
    wm withdraw $top
    wm title $top "vtcl"
    bindtags $top "$top Vtcl all"
    vTcl:FireEvent $top <<Create>>
    wm protocol $top WM_DELETE_WINDOW "vTcl:FireEvent $top <<DeleteWindow>>"

    ###################
    # SETTING GEOMETRY
    ###################

    vTcl:FireEvent $base <<Ready>>
}

proc vTclWindow.top72 {base} {
    if {$base == ""} {
        set base .top72
    }
    if {[winfo exists $base]} {
        wm deiconify $base; return
    }
    set top $base
    ###################
    # CREATING WIDGETS
    ###################
    vTcl:toplevel $top -class Toplevel
    wm focusmodel $top passive
    wm geometry $top +130+200; update
    wm maxsize $top 1284 1006
    wm minsize $top 111 1
    wm overrideredirect $top 0
    wm resizable $top 1 1
    wm deiconify $top
    wm title $top "Compound Container Tutorial"
    vTcl:DefineAlias "$top" "Toplevel1" vTcl:Toplevel:WidgetProc "" 1
    bindtags $top "$top Toplevel all _TopLevel"
    vTcl:FireEvent $top <<Create>>
    wm protocol $top WM_DELETE_WINDOW "vTcl:FireEvent $top <<DeleteWindow>>"

    label $top.lab73 \
        -anchor w -justify left \
        -text {Compound Containers display compounds as a "black box" without revealing the underlying widgets.

Compound Containers can be used alone, but they cannot redefine the widget procedure.

Use megawidgets (the widget next to compound containers) for this.} 
    vTcl:DefineAlias "$top.lab73" "Label1" vTcl:WidgetProc "Toplevel1" 1
    label $top.lab75 \
        -anchor w -background #cbcbe6e6ffff -justify left \
        -text {Below is a simple compound, inserted without a compound container.
Note that all subwidgets show up in the widget tree.} 
    vTcl:DefineAlias "$top.lab75" "Label2" vTcl:WidgetProc "Toplevel1" 1
    frame $top.cpd74 \
        -borderwidth 2 -relief raised -height 0 -takefocus 1 
    vTcl:DefineAlias "$top.cpd74" "TestButton1" vTcl:WidgetProc "Toplevel1" 1
    bindtags $top.cpd74 "$top.cpd74 Frame $top all BitmapButtonTop"
    set site_3_0 $top.cpd74
    frame $site_3_0.upframe \
        -borderwidth 2 -height 3 
    bindtags $site_3_0.upframe "$site_3_0.upframe Frame $top all BitmapButtonSub1"
    frame $site_3_0.centerframe \
        -borderwidth 2 
    bindtags $site_3_0.centerframe "$site_3_0.centerframe Frame $top all BitmapButtonSub1"
    set site_4_0 $site_3_0.centerframe
    frame $site_4_0.leftframe \
        -borderwidth 2 -width 3 
    bindtags $site_4_0.leftframe "$site_4_0.leftframe Frame $top all BitmapButtonSub2"
    frame $site_4_0.rightframe \
        -borderwidth 2 -width 2 
    bindtags $site_4_0.rightframe "$site_4_0.rightframe Frame $top all BitmapButtonSub2"
    frame $site_4_0.05 \
        -borderwidth 1 
    bindtags $site_4_0.05 "$site_4_0.05 Frame $top all BitmapButtonSub2"
    set site_5_0 $site_4_0.05
    label $site_5_0.06 \
        -borderwidth 0 \
        -image [vTcl:image:get_image [file join D:/ cygwin home cgavin vtcl images edit ok.gif]] \
        -text label 
    bindtags $site_5_0.06 "$site_5_0.06 Label $top all BitmapButtonSub3"
    label $site_5_0.07 \
        -borderwidth 1 -text Button 
    bindtags $site_5_0.07 "$site_5_0.07 Label $top all BitmapButtonSub3"
    pack $site_5_0.06 \
        -in $site_5_0 -anchor center -expand 0 -fill none -side top 
    pack $site_5_0.07 \
        -in $site_5_0 -anchor center -expand 0 -fill none -side top 
    pack $site_4_0.leftframe \
        -in $site_4_0 -anchor center -expand 0 -fill none -side left 
    pack $site_4_0.rightframe \
        -in $site_4_0 -anchor center -expand 0 -fill none -side right 
    pack $site_4_0.05 \
        -in $site_4_0 -anchor center -expand 0 -fill none -side top 
    frame $site_3_0.downframe \
        -borderwidth 2 -relief groove -height 2 
    bindtags $site_3_0.downframe "$site_3_0.downframe Frame $top all BitmapButtonSub1"
    pack $site_3_0.upframe \
        -in $site_3_0 -anchor center -expand 0 -fill none -side top 
    pack $site_3_0.centerframe \
        -in $site_3_0 -anchor center -expand 0 -fill none -side top 
    pack $site_3_0.downframe \
        -in $site_3_0 -anchor center -expand 0 -fill none -side bottom 
    label $top.lab77 \
        -anchor w -background #cbcbe6e6ffff -justify left \
        -text {Now, the same widget inserted with a "Compound Container".
To insert a compound container, click on the toolbar icon (with red and blue squares),
then select a compound from the list.} 
    vTcl:DefineAlias "$top.lab77" "Label3" vTcl:WidgetProc "Toplevel1" 1
    vTcl::widgets::core::compoundcontainer::createCmd $top.com78 \
        -compoundClass {bitmap button} 
    vTcl:DefineAlias "$top.com78" "CompoundContainer1" vTcl::widgets::core::compoundcontainer::widgetProc "Toplevel1" 1
    label $top.lab79 \
        -anchor w -background #ececdc0b9413 -justify left \
        -text {Note how the compound container displays in the widget tree.
Also, note how when you click on it it behaves as one single widget.} 
    vTcl:DefineAlias "$top.lab79" "Label4" vTcl:WidgetProc "Toplevel1" 1
    ###################
    # SETTING GEOMETRY
    ###################
    pack $top.lab73 \
        -in $top -anchor center -expand 0 -fill x -padx 5 -pady 5 -side top 
    pack $top.lab75 \
        -in $top -anchor center -expand 0 -fill x -padx 5 -pady 5 -side top 
    pack $top.cpd74 \
        -in $top -anchor center -expand 0 -fill none -side top 
    pack $top.lab77 \
        -in $top -anchor center -expand 0 -fill x -padx 5 -pady 5 -side top 
    pack $top.com78 \
        -in $top -anchor center -expand 0 -fill none -side top 
    pack $top.lab79 \
        -in $top -anchor center -expand 0 -fill x -padx 5 -pady 5 -side top 

    vTcl:FireEvent $base <<Ready>>
}

#############################################################################
## Binding tag:  _TopLevel

bind "_TopLevel" <<Create>> {
    if {![info exists _topcount]} {set _topcount 0}; incr _topcount
}
bind "_TopLevel" <<DeleteWindow>> {
    destroy %W; if {$_topcount == 0} {exit}
}
bind "_TopLevel" <Destroy> {
    if {[winfo toplevel %W] == "%W"} {incr _topcount -1}
}
#############################################################################
## Binding tag:  BitmapButtonSub1

bind "BitmapButtonSub1" <Button-1> {
    ::bitmapbutton::mouse_down [::bitmapbutton::get_parent %W] %X %Y
}
bind "BitmapButtonSub1" <ButtonRelease-1> {
    ::bitmapbutton::mouse_up [::bitmapbutton::get_parent %W] %X %Y
}
bind "BitmapButtonSub1" <Motion> {
    ::bitmapbutton::mouse_inside [::bitmapbutton::get_parent %W] %X %Y
}
#############################################################################
## Binding tag:  BitmapButtonSub2

bind "BitmapButtonSub2" <Button-1> {
    ::bitmapbutton::mouse_down [::bitmapbutton::get_parent %W 2] %X %Y
}
bind "BitmapButtonSub2" <ButtonRelease-1> {
    ::bitmapbutton::mouse_up [::bitmapbutton::get_parent %W 2] %X %Y
}
bind "BitmapButtonSub2" <Motion> {
    ::bitmapbutton::mouse_inside [::bitmapbutton::get_parent %W 2] %X %Y
}
#############################################################################
## Binding tag:  BitmapButtonSub3

bind "BitmapButtonSub3" <Button-1> {
    ::bitmapbutton::mouse_down [::bitmapbutton::get_parent %W 3] %X %Y
}
bind "BitmapButtonSub3" <ButtonRelease-1> {
    ::bitmapbutton::mouse_up [::bitmapbutton::get_parent %W 3] %X %Y
}
bind "BitmapButtonSub3" <Motion> {
    ::bitmapbutton::mouse_inside [::bitmapbutton::get_parent %W 3] %X %Y
}
#############################################################################
## Binding tag:  BitmapButtonTop

bind "BitmapButtonTop" <Button-1> {
    ::bitmapbutton::mouse_down %W %X %Y
}
bind "BitmapButtonTop" <ButtonRelease-1> {
    ::bitmapbutton::mouse_up %W %X %Y
}
bind "BitmapButtonTop" <FocusIn> {
    # puts "Bitmapbutton gets focus"
%W.centerframe.05 configure -relief groove
}
bind "BitmapButtonTop" <FocusOut> {
    # puts "Bitmapbutton loses focus"
%W.centerframe.05 configure -relief flat
}
bind "BitmapButtonTop" <Key-space> {
    #TODO: your <KeyPress-space> event handler here
::bitmapbutton::mouse_down %W [winfo rootx %W] [winfo rooty %W]
}
bind "BitmapButtonTop" <KeyRelease-space> {
    #TODO: your <KeyRelease-space> event handler here
::bitmapbutton::mouse_up %W [winfo rootx %W] [winfo rooty %W]
}
bind "BitmapButtonTop" <Motion> {
    ::bitmapbutton::mouse_inside %W %X %Y
}

Window show .
Window show .top72

main $argc $argv