compound_container.tcl

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

#!/bin/sh
# the next line restarts using wish\
exec wish "$0" "$@" 

if {![info exists vTcl(sourcing)]} {

    package require Tk
    switch $tcl_platform(platform) {
	windows {
            option add *Button.padY 0
	}
	default {
            option add *Scrollbar.width 10
            option add *Scrollbar.highlightThickness 0
            option add *Scrollbar.elementBorderWidth 2
            option add *Scrollbar.borderWidth 2
	}
    }
    
}

#############################################################################
# Visual Tcl v1.60 Project
#

#############################################################################
## Compound: user / bitmap button
namespace eval {vTcl::compounds::user::{bitmap button}} {

set bindtags {
    BitmapButtonSub1
    BitmapButtonSub2
    BitmapButtonSub3
    BitmapButtonTop
}

set libraries core

set source .top18.cpd19

set class Frame

set procs {
    ::bitmapbutton::mouse_inside
    ::bitmapbutton::mouse_down
    ::bitmapbutton::init
    ::bitmapbutton::show_state
    ::bitmapbutton::mouse_up
    ::bitmapbutton::get_parent
    ::bitmapbutton::set_command
}


proc vTcl:DefineAlias {target alias args} {
    if {![info exists ::vTcl(running)]} {
        return [eval ::vTcl:DefineAlias $target $alias $args]
    }
    set class [vTcl:get_class $target]
    vTcl:set_alias $target [vTcl:next_widget_name $class $target $alias] -noupdate
}


proc infoCmd {target} {
    namespace eval ::widgets::$target {
        array set save {-borderwidth 1 -height 1 -relief 1 -takefocus 1}
    }
    set site_3_0 $target
    namespace eval ::widgets::$site_3_0.upframe {
        array set save {-borderwidth 1 -height 1}
    }
    namespace eval ::widgets::$site_3_0.centerframe {
        array set save {-borderwidth 1}
    }
    set site_4_0 $site_3_0.centerframe
    namespace eval ::widgets::$site_4_0.leftframe {
        array set save {-borderwidth 1 -width 1}
    }
    namespace eval ::widgets::$site_4_0.rightframe {
        array set save {-borderwidth 1 -width 1}
    }
    namespace eval ::widgets::$site_4_0.05 {
        array set save {-borderwidth 1}
    }
    set site_5_0 $site_4_0.05
    namespace eval ::widgets::$site_5_0.06 {
        array set save {-borderwidth 1 -image 1 -text 1}
    }
    namespace eval ::widgets::$site_5_0.07 {
        array set save {-borderwidth 1 -text 1}
    }
    namespace eval ::widgets::$site_3_0.downframe {
        array set save {-borderwidth 1 -height 1 -relief 1}
    }

}


proc bindtagsCmd {} {
#############################################################################
## 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
}
}


proc compoundCmd {target} {
    ::bitmapbutton::init $target

    set items [split $target .]
    set parent [join [lrange $items 0 end-1] .]
    set top [winfo toplevel $parent]
    frame $target  -borderwidth 2 -height 0 -relief raised -takefocus 1 
    vTcl:DefineAlias "$target" "TestButton" vTcl:WidgetProc "$top" 1
    bindtags $target "$target Frame $top all BitmapButtonTop"
    set site_3_0 $target
    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 -height 2 -relief groove 
    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 

}


proc procsCmd {} {
#############################################################################
## Procedure:  ::bitmapbutton::mouse_inside

namespace eval ::bitmapbutton {

proc mouse_inside {W X Y} {
global widget

set button_X [winfo rootx $W]
set button_Y [winfo rooty $W]
set button_width [winfo width $W]
set button_height [winfo height $W]

set N [vTcl:rename $W]
set S "mouse_up"

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_down

namespace eval ::bitmapbutton {

proc mouse_down {W X Y} {
global widget

::bitmapbutton::show_state $W sunken

set N [vTcl:rename $W]
namespace eval ::$N {variable state}

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

}

#############################################################################
## Procedure:  ::bitmapbutton::init

namespace eval ::bitmapbutton {

proc init {W} {
global widget

set N [vTcl:rename $W]
namespace eval ::${N} {
    variable command
    set command ""}
}

}

#############################################################################
## 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:  ::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
            }