461 lines
14 KiB
Tcl
461 lines
14 KiB
Tcl
#!/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
|
||
#
|
||
|
||
|
||
#################################
|
||
# VTCL LIBRARY PROCEDURES
|
||
#
|
||
|
||
if {![info exists vTcl(sourcing)]} {
|
||
#############################################################################
|
||
## Library Procedure: Window
|
||
|
||
proc ::Window {args} {
|
||
## This procedure may be used free of restrictions.
|
||
## Exception added by Christian Gavin on 08/08/02.
|
||
## Other packages and widget toolkits have different licensing requirements.
|
||
## Please read their license agreements for details.
|
||
|
||
global vTcl
|
||
foreach {cmd name newname} [lrange $args 0 2] {}
|
||
set rest [lrange $args 3 end]
|
||
if {$name == "" || $cmd == ""} { return }
|
||
if {$newname == ""} { set newname $name }
|
||
if {$name == "."} { wm withdraw $name; return }
|
||
set exists [winfo exists $newname]
|
||
switch $cmd {
|
||
show {
|
||
if {$exists} {
|
||
wm deiconify $newname
|
||
} elseif {[info procs vTclWindow$name] != ""} {
|
||
eval "vTclWindow$name $newname $rest"
|
||
}
|
||
if {[winfo exists $newname] && [wm state $newname] == "normal"} {
|
||
vTcl:FireEvent $newname <<Show>>
|
||
}
|
||
}
|
||
hide {
|
||
if {$exists} {
|
||
wm withdraw $newname
|
||
vTcl:FireEvent $newname <<Hide>>
|
||
return}
|
||
}
|
||
iconify { if $exists {wm iconify $newname; return} }
|
||
destroy { if $exists {destroy $newname; return} }
|
||
}
|
||
}
|
||
#############################################################################
|
||
## Library Procedure: vTcl:DefineAlias
|
||
|
||
proc ::vTcl:DefineAlias {target alias widgetProc top_or_alias cmdalias} {
|
||
## This procedure may be used free of restrictions.
|
||
## Exception added by Christian Gavin on 08/08/02.
|
||
## Other packages and widget toolkits have different licensing requirements.
|
||
## Please read their license agreements for details.
|
||
|
||
global widget
|
||
set widget($alias) $target
|
||
set widget(rev,$target) $alias
|
||
if {$cmdalias} {
|
||
interp alias {} $alias {} $widgetProc $target
|
||
}
|
||
if {$top_or_alias != ""} {
|
||
set widget($top_or_alias,$alias) $target
|
||
if {$cmdalias} {
|
||
interp alias {} $top_or_alias.$alias {} $widgetProc $target
|
||
}
|
||
}
|
||
}
|
||
#############################################################################
|
||
## Library Procedure: vTcl:DoCmdOption
|
||
|
||
proc ::vTcl:DoCmdOption {target cmd} {
|
||
## This procedure may be used free of restrictions.
|
||
## Exception added by Christian Gavin on 08/08/02.
|
||
## Other packages and widget toolkits have different licensing requirements.
|
||
## Please read their license agreements for details.
|
||
|
||
## menus are considered toplevel windows
|
||
set parent $target
|
||
while {[winfo class $parent] == "Menu"} {
|
||
set parent [winfo parent $parent]
|
||
}
|
||
|
||
regsub -all {\%widget} $cmd $target cmd
|
||
regsub -all {\%top} $cmd [winfo toplevel $parent] cmd
|
||
|
||
uplevel #0 [list eval $cmd]
|
||
}
|
||
#############################################################################
|
||
## Library Procedure: vTcl:FireEvent
|
||
|
||
proc ::vTcl:FireEvent {target event {params {}}} {
|
||
## This procedure may be used free of restrictions.
|
||
## Exception added by Christian Gavin on 08/08/02.
|
||
## Other packages and widget toolkits have different licensing requirements.
|
||
## Please read their license agreements for details.
|
||
|
||
## The window may have disappeared
|
||
if {![winfo exists $target]} return
|
||
## Process each binding tag, looking for the event
|
||
foreach bindtag [bindtags $target] {
|
||
set tag_events [bind $bindtag]
|
||
set stop_processing 0
|
||
foreach tag_event $tag_events {
|
||
if {$tag_event == $event} {
|
||
set bind_code [bind $bindtag $tag_event]
|
||
foreach rep "\{%W $target\} $params" {
|
||
regsub -all [lindex $rep 0] $bind_code [lindex $rep 1] bind_code
|
||
}
|
||
set result [catch {uplevel #0 $bind_code} errortext]
|
||
if {$result == 3} {
|
||
## break exception, stop processing
|
||
set stop_processing 1
|
||
} elseif {$result != 0} {
|
||
bgerror $errortext
|
||
}
|
||
break
|
||
}
|
||
}
|
||
if {$stop_processing} {break}
|
||
}
|
||
}
|
||
#############################################################################
|
||
## Library Procedure: vTcl:Toplevel:WidgetProc
|
||
|
||
proc ::vTcl:Toplevel:WidgetProc {w args} {
|
||
## This procedure may be used free of restrictions.
|
||
## Exception added by Christian Gavin on 08/08/02.
|
||
## Other packages and widget toolkits have different licensing requirements.
|
||
## Please read their license agreements for details.
|
||
|
||
if {[llength $args] == 0} {
|
||
## If no arguments, returns the path the alias points to
|
||
return $w
|
||
}
|
||
set command [lindex $args 0]
|
||
set args [lrange $args 1 end]
|
||
switch -- [string tolower $command] {
|
||
"setvar" {
|
||
foreach {varname value} $args {}
|
||
if {$value == ""} {
|
||
return [set ::${w}::${varname}]
|
||
} else {
|
||
return [set ::${w}::${varname} $value]
|
||
}
|
||
}
|
||
"hide" - "show" {
|
||
Window [string tolower $command] $w
|
||
}
|
||
"showmodal" {
|
||
## modal dialog ends when window is destroyed
|
||
Window show $w; raise $w
|
||
grab $w; tkwait window $w; grab release $w
|
||
}
|
||
"startmodal" {
|
||
## ends when endmodal called
|
||
Window show $w; raise $w
|
||
set ::${w}::_modal 1
|
||
grab $w; tkwait variable ::${w}::_modal; grab release $w
|
||
}
|
||
"endmodal" {
|
||
## ends modal dialog started with startmodal, argument is var name
|
||
set ::${w}::_modal 0
|
||
Window hide $w
|
||
}
|
||
default {
|
||
uplevel $w $command $args
|
||
}
|
||
}
|
||
}
|
||
#############################################################################
|
||
## Library Procedure: vTcl:WidgetProc
|
||
|
||
proc ::vTcl:WidgetProc {w args} {
|
||
## This procedure may be used free of restrictions.
|
||
## Exception added by Christian Gavin on 08/08/02.
|
||
## Other packages and widget toolkits have different licensing requirements.
|
||
## Please read their license agreements for details.
|
||
|
||
if {[llength $args] == 0} {
|
||
## If no arguments, returns the path the alias points to
|
||
return $w
|
||
}
|
||
|
||
set command [lindex $args 0]
|
||
set args [lrange $args 1 end]
|
||
uplevel $w $command $args
|
||
}
|
||
#############################################################################
|
||
## Library Procedure: vTcl:toplevel
|
||
|
||
proc ::vTcl:toplevel {args} {
|
||
## This procedure may be used free of restrictions.
|
||
## Exception added by Christian Gavin on 08/08/02.
|
||
## Other packages and widget toolkits have different licensing requirements.
|
||
## Please read their license agreements for details.
|
||
|
||
uplevel #0 eval toplevel $args
|
||
set target [lindex $args 0]
|
||
namespace eval ::$target {set _modal 0}
|
||
}
|
||
}
|
||
|
||
|
||
if {[info exists vTcl(sourcing)]} {
|
||
|
||
proc vTcl:project:info {} {
|
||
set base .top43
|
||
namespace eval ::widgets::$base {
|
||
set set,origin 1
|
||
set set,size 1
|
||
set runvisible 1
|
||
}
|
||
namespace eval ::widgets::$base.lab44 {
|
||
array set save {-disabledforeground 1 -font 1 -text 1}
|
||
}
|
||
namespace eval ::widgets::$base.cpd45 {
|
||
array set save {-disabledforeground 1 -font 1 -text 1}
|
||
}
|
||
namespace eval ::widgets::$base.cpd46 {
|
||
array set save {-disabledforeground 1 -font 1 -text 1}
|
||
}
|
||
namespace eval ::widgets::$base.che47 {
|
||
array set save {-disabledforeground 1 -font 1 -text 1 -variable 1}
|
||
}
|
||
namespace eval ::widgets::$base.but48 {
|
||
array set save {-command 1 -disabledforeground 1 -font 1 -text 1}
|
||
}
|
||
namespace eval ::widgets::$base.ent49 {
|
||
array set save {-background 1 -insertbackground 1 -textvariable 1}
|
||
}
|
||
namespace eval ::widgets::$base.cpd50 {
|
||
array set save {-background 1 -insertbackground 1 -textvariable 1}
|
||
}
|
||
namespace eval ::widgets::$base.cpd51 {
|
||
array set save {-background 1 -insertbackground 1 -textvariable 1}
|
||
}
|
||
namespace eval ::widgets::$base.lis43 {
|
||
array set save {-background 1 -listvariable 1}
|
||
}
|
||
namespace eval ::widgets::$base.lab45 {
|
||
array set save {-disabledforeground 1 -font 1 -text 1}
|
||
}
|
||
namespace eval ::widgets_bindings {
|
||
set tagslist _TopLevel
|
||
}
|
||
namespace eval ::vTcl::modules::main {
|
||
set procs {
|
||
init
|
||
main
|
||
cobol_update
|
||
}
|
||
set compounds {
|
||
}
|
||
set projectType single
|
||
}
|
||
}
|
||
}
|
||
|
||
#################################
|
||
# USER DEFINED PROCEDURES
|
||
#
|
||
#############################################################################
|
||
## Procedure: main
|
||
|
||
proc ::main {argc argv} {
|
||
global cobol_fields widget
|
||
set cobol_fields {
|
||
name 40
|
||
address 50
|
||
phone 15
|
||
endpgm 1
|
||
}
|
||
|
||
global nomes_anteriores
|
||
set nomes_anteriores {}
|
||
|
||
bind all <Return> do_exit
|
||
}
|
||
#############################################################################
|
||
## Procedure: cobol_update
|
||
|
||
proc ::cobol_update {} {
|
||
global widget
|
||
global nomes_anteriores name
|
||
|
||
puts "tcl-TC LOG: lappend nomes_anteriores $name"
|
||
lappend nomes_anteriores $name
|
||
focus $widget(nome_entry)
|
||
}
|
||
|
||
#############################################################################
|
||
## 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 1x1+0+0; update
|
||
wm maxsize $top 1265 994
|
||
wm minsize $top 1 1
|
||
wm overrideredirect $top 0
|
||
wm resizable $top 1 1
|
||
wm withdraw $top
|
||
wm title $top "vtcl.tcl"
|
||
bindtags $top "$top Vtcl.tcl all"
|
||
vTcl:FireEvent $top <<Create>>
|
||
wm protocol $top WM_DELETE_WINDOW "vTcl:FireEvent $top <<DeleteWindow>>"
|
||
|
||
###################
|
||
# SETTING GEOMETRY
|
||
###################
|
||
|
||
vTcl:FireEvent $base <<Ready>>
|
||
}
|
||
|
||
proc vTclWindow.top43 {base} {
|
||
if {$base == ""} {
|
||
set base .top43
|
||
}
|
||
if {[winfo exists $base]} {
|
||
wm deiconify $base; return
|
||
}
|
||
set top $base
|
||
###################
|
||
# CREATING WIDGETS
|
||
###################
|
||
vTcl:toplevel $top -class Toplevel \
|
||
-highlightcolor black
|
||
wm focusmodel $top passive
|
||
wm geometry $top 570x523+327+247; update
|
||
wm maxsize $top 1265 994
|
||
wm minsize $top 1 1
|
||
wm overrideredirect $top 0
|
||
wm resizable $top 1 1
|
||
wm deiconify $top
|
||
wm title $top "New Toplevel 1"
|
||
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.lab44 \
|
||
-disabledforeground #a1a4a1 -font {helvetica 18 bold} -text Nome:
|
||
vTcl:DefineAlias "$top.lab44" "Label1" vTcl:WidgetProc "Toplevel1" 1
|
||
label $top.cpd45 \
|
||
-disabledforeground #a1a4a1 -font {helvetica 18 bold} -text Endere<EFBFBD>o:
|
||
vTcl:DefineAlias "$top.cpd45" "Label2" vTcl:WidgetProc "Toplevel1" 1
|
||
label $top.cpd46 \
|
||
-disabledforeground #a1a4a1 -font {helvetica 18 bold} -text Telefone:
|
||
vTcl:DefineAlias "$top.cpd46" "Label3" vTcl:WidgetProc "Toplevel1" 1
|
||
checkbutton $top.che47 \
|
||
-disabledforeground #a1a4a1 -font {helvetica 10} -text concluido \
|
||
-variable endpgm
|
||
vTcl:DefineAlias "$top.che47" "Checkbutton1" vTcl:WidgetProc "Toplevel1" 1
|
||
button $top.but48 \
|
||
-command do_exit -disabledforeground #a1a4a1 \
|
||
-font {helvetica 10 bold} -text entra
|
||
vTcl:DefineAlias "$top.but48" "Button1" vTcl:WidgetProc "Toplevel1" 1
|
||
entry $top.ent49 \
|
||
-background white -insertbackground black -textvariable name
|
||
vTcl:DefineAlias "$top.ent49" "nome_entry" vTcl:WidgetProc "Toplevel1" 1
|
||
entry $top.cpd50 \
|
||
-background white -insertbackground black -textvariable address
|
||
vTcl:DefineAlias "$top.cpd50" "Entry2" vTcl:WidgetProc "Toplevel1" 1
|
||
entry $top.cpd51 \
|
||
-background white -insertbackground black -textvariable phone
|
||
vTcl:DefineAlias "$top.cpd51" "Entry3" vTcl:WidgetProc "Toplevel1" 1
|
||
listbox $top.lis43 \
|
||
-background white -listvariable nomes_anteriores
|
||
vTcl:DefineAlias "$top.lis43" "Listbox1" vTcl:WidgetProc "Toplevel1" 1
|
||
label $top.lab45 \
|
||
-disabledforeground #a1a4a1 -font {verdana -11} \
|
||
-text {nomes
|
||
anteriores}
|
||
vTcl:DefineAlias "$top.lab45" "Label4" vTcl:WidgetProc "Toplevel1" 1
|
||
###################
|
||
# SETTING GEOMETRY
|
||
###################
|
||
place $top.lab44 \
|
||
-x 25 -y 35 -anchor nw -bordermode ignore
|
||
place $top.cpd45 \
|
||
-x 25 -y 100 -anchor nw
|
||
place $top.cpd46 \
|
||
-x 25 -y 170 -anchor nw
|
||
place $top.che47 \
|
||
-x 30 -y 440 -anchor nw -bordermode ignore
|
||
place $top.but48 \
|
||
-x 240 -y 430 -anchor nw -bordermode ignore
|
||
place $top.ent49 \
|
||
-x 140 -y 40 -width 403 -height 27 -anchor nw -bordermode ignore
|
||
place $top.cpd50 \
|
||
-x 175 -y 100 -width 368 -height 27 -anchor nw
|
||
place $top.cpd51 \
|
||
-x 175 -y 175 -width 273 -height 27 -anchor nw
|
||
place $top.lis43 \
|
||
-x 155 -y 245 -width 383 -height 156 -anchor nw -bordermode ignore
|
||
place $top.lab45 \
|
||
-x 35 -y 250 -anchor nw -bordermode ignore
|
||
|
||
vTcl:FireEvent $base <<Ready>>
|
||
}
|
||
|
||
#############################################################################
|
||
## Binding tag: _TopLevel
|
||
|
||
bind "_TopLevel" <<Create>> {
|
||
if {![info exists _topcount]} {set _topcount 0}; incr _topcount
|
||
}
|
||
bind "_TopLevel" <<DeleteWindow>> {
|
||
if {[set ::%W::_modal]} {
|
||
vTcl:Toplevel:WidgetProc %W endmodal
|
||
} else {
|
||
destroy %W; if {$_topcount == 0} {exit}
|
||
}
|
||
}
|
||
bind "_TopLevel" <Destroy> {
|
||
if {[winfo toplevel %W] == "%W"} {incr _topcount -1}
|
||
}
|
||
|
||
Window show .
|
||
Window show .top43
|
||
|
||
main $argc $argv
|