Posted to tcl by egavilan at Tue Oct 20 21:36:30 GMT 2015view raw
- namespace eval ::ttk {
- bind Wrapframe <FocusIn> {%W#border state focus}
- bind Wrapframe <FocusOut> {%W#border state !focus}
- bind Wrapframe <Destroy> {rename %W {}}
- interp alias {} ::ttk::text {} ::ttk::WrapWidget text
- interp alias {} ::ttk::listbox {} ::ttk::WrapWidget listbox
- interp alias {} ::ttk::canvas {} ::ttk::WrapWidget canvas
- proc WrapWidget {class path args} {
- # handle the args
- set args [dict replace $args \
- -background white \
- -borderwidth 0 \
- -highlightthickness 0]
- set args [dict remove $args -bg -bd]
- # real widget
- set rw $path.$class
- # create the container frame and the widget
- frame $path -style TEntry -class Wrapframe
- uplevel 1 [linsert $args 0 $class $rw]
- pack $rw -expand 1 -fill both -padx 2 -pady 2
- # rename the container widget cmd and install a proxy cmd
- # to the real one
- rename ::$path ::$path#border
- interp alias {} ::$path {} ::ttk::WrapProxy $rw
- # adjust bindtags to contain the wrapper name too
- bindtags $rw [linsert [bindtags $rw] 0 $path]
- # adjust the select{fore|back}ground with the theme
- bind $rw <<ThemeChanged>> [list apply {rw {
- $rw configure -selectbackground \
- [ttk::style configure . -selectbackground]
- $rw configure -selectforeground \
- [ttk::style configure . -selectforeground]
- }} $rw]
- after idle [list after 0 [list event generate $rw <<ThemeChanged>>]]
- return $path
- }
- # prevent the wrapper window to take focus
- proc WrapProxy {w args} {
- if {[lindex $args 0] eq "cget" &&
- [lindex $args 1] eq "-takefocus"
- } then {
- return 0
- }
- uplevel 1 [linsert $args 0 $w]
- }
- }
- # create a toplevel with a background ttk::frame
- proc ttk::toplevel {path args} {
- ::toplevel $path {*}$args
- while 1 {
- set bw ${path}.background#[incr i]
- if {![winfo exists $bw]} break
- }
- place [frame $bw] -x 0 -y 0 -relwidth 1.0 -relheight 1.0
- return $path
- }