Posted to tcl by patthoyts at Tue Dec 29 23:14:13 GMT 2009view raw
- # Replace the standard notebook tab with one that includes a close
- # button.
- # In future versions of ttk this will be supported more directly when
- # the identify command will be able to identify parts of the tab.
- package require Tk
- namespace eval ::ButtonNotebook {
- }
- # Tk 8.6 has the Visual Styles element engine on windows. If this is
- # available we use it to get proper windows close buttons.
- #
- proc ::ButtonNotebook::CreateElements {} {
- if {[lsearch -exact [ttk::style element names] close] == -1} {
- if {[catch {
- # WINDOW WP_SMALLCLOSEBUTTON (19)
- # WINDOW WP_MDICLOSEBUTTON (20)
- # WINDOW WP_MDIRESTOREBUTTON (22)
- #ttk::style element create close vsapi \
- # WINDOW 20 {disabled 4 {active pressed} 3 active 2 {} 1}
- ttk::style element create close vsapi \
- EXPLORERBAR 2 {disabled 4 {active pressed} 3 active 2 {} 1}
- ttk::style element create detach vsapi \
- WINDOW 22 {disabled 4 {active pressed} 3 active 2 {} 1}
- }]} then {
- # No XP element engine - use images...
- CreateImageElements
- }
- }
- }
- proc ::ButtonNotebook::CreateImageElements {} {
- # Create two image based elements to provide buttons to close the
- # tabs or to detach a tab and turn it into a toplevel.
- namespace eval ::img {}
- set imgdir [file join [file dirname [info script]] images]
- image create photo ::img::close -file [file join $imgdir xhn.gif]
- image create photo ::img::closepressed -file [file join $imgdir xhd.gif]
- image create photo ::img::closeactive -file [file join $imgdir xhu.gif]
- image create photo ::img::detach -file [file join $imgdir dhn.gif]
- image create photo ::img::detachup -file [file join $imgdir dhu.gif]
- image create photo ::img::detachdown -file [file join $imgdir dhd.gif]
- if {[lsearch -exact [ttk::style element names] close] == -1} {
- if {[catch {
- ttk::style element create close image \
- [list ::img::close \
- {active user3} ::img::close \
- {active pressed !disabled} ::img::closepressed \
- {active !disabled} ::img::closeactive] \
- -border 3 -sticky {}
- ttk::style element create detach image \
- [list ::img::detach \
- {active pressed !disabled} ::img::detachdown \
- {active !disabled} ::img::detachup] \
- -border 3 -sticky {}
- } err]} { puts stderr $err }
- }
- }
- proc ::ButtonNotebook::Init {{pertab 0}} {
- CreateElements
- # This places the buttons on the right end of the tab area -- but in
- # Tk 8.5 we cannot identify these elements.
- if {!$pertab} {
- ttk::style layout ButtonNotebook {
- ButtonNotebook.client -sticky nswe
- ButtonNotebook.close -side right -sticky ne
- ButtonNotebook.detach -side right -sticky ne
- }
- }
- # This places the button elements on each tab which uses quite a
- # lot of space but we can identify the elements. Changes to the
- # widget state affect all the button elements though.
- if {$pertab} {
- ttk::style layout ButtonNotebook {
- ButtonNotebook.client -sticky nswe
- }
- ttk::style layout ButtonNotebook.Tab {
- ButtonNotebook.tab -sticky nswe -children {
- ButtonNotebook.focus -side top -sticky nswe -children {
- ButtonNotebook.padding -side right -sticky nswe -children {
- ButtonNotebook.close -side right -sticky {}
- }
- ButtonNotebook.label -side left -sticky {}
- }
- }
- }
- #if {$::tcl_platform(platform) eq "windows"} {} ??
- ttk::style configure ButtonNotebook.Tab -width -8
- ttk::style configure ButtonNotebook.Tab -padding {8 0 0 0}
- }
- bind TNotebook <ButtonPress-1> {+::ButtonNotebook::Press %W %x %y}
- bind TNotebook <Motion> {+::ButtonNotebook::Drag %W %x %y %X %Y}
- bind TNotebook <ButtonRelease-1> {+::ButtonNotebook::Release %W %x %y %X %Y}
- bind TNotebook <<ThemeChanged>> [namespace code [list Init $pertab]]
- }
- # Hook in some event extras:
- # set the state to pressed if button down over a button element.
- proc ::ButtonNotebook::Press {w x y} {
- set e [$w identify $x $y]
- if {[string match "*close" $e] || [string match "*detach" $e]} {
- set index [$w index @$x,$y]
- set tw [lindex [$w tabs] $index]
- if {[winfo class $tw] ne "Noclose"} {
- $w state pressed
- }
- } else {
- upvar #0 [namespace current]::$w state
- if {![info exists state]} {
- # FIX ME: dragging tabs isnt working so well at the moment
- #set state(drag) 1
- #set state(drag_index) [$w index @$x,$y]
- #set state(drag_under) $state(drag_index)
- #set state(drag_from_x) $x
- #set state(draw_from_y) $y
- #set state(drag_indic) [ttk::label $w._indic -text v]
- }
- }
- }
- proc ::ButtonNotebook::Drag {w x y rootX rootY} {
- upvar #0 [namespace current]::$w state
- # Use user3 to prevent activation of a non-closing close element
- set contained [lindex [$w tabs] [$w index @$x,$y]]
- if {[winfo class $contained] eq "Noclose"} {
- $w state user3
- } else { $w state !user3 }
- if {[info exists state]} {
- if {[winfo containing $rootX $rootY] eq $w} {
- set index [$w index @$x,$y]
- if {$index != $state(drag_under)} {
- place $state(drag_indic) -anchor nw -x $x -y 0
- set state(drag_under) $index
- }
- }
- }
- }
- # On release, do the button action if any.
- proc ::ButtonNotebook::Release {w x y rootX rootY} {
- $w state !pressed
- set e [$w identify $x $y]
- set index [$w index @$x,$y]
- if {[string match "*close" $e]} {
- set tw [lindex [$w tabs] $index]
- if {[winfo class $tw] ne "Noclose"} {
- $w forget $index
- event generate $w <<NotebookClosedTab>>
- }
- } elseif {[string match "*detach" $e]} {
- Detach $w $index
- } else {
- upvar #0 [namespace current]::$w state
- if {[info exists state]} {
- set dropwin [winfo containing $rootX $rootY]
- if {$dropwin eq {}} {
- Detach $w $state(drag_index)
- } elseif {$dropwin eq $w && $index != $state(drag_index)} {
- Move $w $state(drag_index) $index
- }
- destroy $state(drag_indic)
- unset state
- }
- }
- }
- # Move a tab from old index to new index position.
- proc ::ButtonNotebook::Move {notebook old_index new_index} {
- set tab [lindex [$notebook tabs] $old_index]
- set title [$notebook tab $old_index -text]
- $notebook forget $old_index
- if {[string is integer -strict $new_index]} {
- incr new_index -1
- if {$new_index < 0} {set new_index 0}
- if {$new_index > [llength [$notebook tabs]]} { set new_index end }
- } else {
- set new_index end
- }
- $notebook insert $new_index $tab -text $title
- }
- # Turn a tab into a toplevel (must be a tk::frame)
- proc ::ButtonNotebook::Detach {notebook index} {
- set tab [lindex [$notebook tabs] $index]
- set title [$notebook tab $index -text]
- $notebook forget $index
- wm manage $tab
- wm title $tab $title
- wm protocol $tab WM_DELETE_WINDOW \
- [namespace code [list Attach $notebook $tab $index]]
- bind $tab <Configure> \
- [namespace code [list Debug $notebook "Configure %wx%h %x,%y"]]
- bind $tab <Expose> [namespace code [list Debug $notebook "Expose"]]
- bind $tab <Activate> [namespace code [list Debug $notebook "Activate"]]
- bind $tab <Deactivate> [namespace code [list Debug $notebook "Deactivate"]]
- bind $tab <ButtonPress> [namespace code [list Debug $notebook "Button"]]
- bind $tab <Visibility> \
- [namespace code [list Debug $notebook "Visibility %s"]]
- event generate $tab <<DetachedTab>>
- }
- proc ::ButtonNotebook::Debug {notebook msg} {
- if {[winfo exists $notebook.page0.text]} {
- $notebook.page0.text insert end $msg\n {}
- $notebook.page0.text see end
- }
- }
- # Attach a toplevel to the notebook
- proc ::ButtonNotebook::Attach {notebook tab {index end}} {
- set title [wm title $tab]
- wm forget $tab
- if {[catch {
- if {[catch {$notebook insert $index $tab -text $title} err]} {
- $notebook add $tab -text $title
- }
- $notebook select $tab
- } err]} {
- puts stderr "AttachWindow: $err"
- wm manage $w
- wm title $w $title
- }
- }
- proc ::ButtonNotebook::Test {} {
- variable tabtest
- set dlg [toplevel .test[incr tabtest]]
- wm title $dlg "Notebook test"
- wm withdraw $dlg
- set nb [ttk::notebook $dlg.nb -style ButtonNotebook]
- frame $nb.page0 -background red -width 100 -height 100
- frame $nb.page1 -background blue -width 100 -height 100
- frame $nb.page2 -background green -width 100 -height 100 -class Noclose
- frame $nb.page3 -background tomato -width 100 -height 100
- $nb add $nb.page0 -text One
- $nb add $nb.page1 -text Two
- $nb add $nb.page2 -text Three
- $nb add $nb.page3 -text "Some really long label."
- set txt [text $nb.page0.text -height 10 -width 10]
- set vs [scrollbar $nb.page0.vs -command [list $txt yview]]
- $txt configure -yscrollcommand [list $vs set]
- grid $txt $vs -sticky news
- grid rowconfigure $nb.page0 0 -weight 1
- grid columnconfigure $nb.page0 0 -weight 1
- grid $dlg.nb -sticky news
- grid rowconfigure $dlg 0 -weight 1
- grid columnconfigure $dlg 0 -weight 1
- bind TNotebook <Motion> [string map [list %txt $txt] {
- %txt insert end [%W identify %x %y] {} "\n" {}
- %txt see end
- }]
- bind $dlg <Control-F2> {console show}
- wm withdraw .
- wm protocol $dlg WM_DELETE_WINDOW {exit}
- wm geometry $dlg 320x240
- wm deiconify $dlg
- }
- ::ButtonNotebook::Init 1
- # The following line causes the Test procedure to be run if this file
- # is run standalone.
- puts [winfo class .]
- if {[string match "Tab*" [winfo class .]]} {
- ::ButtonNotebook::Test
- tkwait window .
- }