1#!/bin/wish84.exe 2 3# Copyright (c) 2002-2011 Tim Baker 4 5set VERSION 2.4.1 6 7package require Tk 8.4 8 9set thisPlatform $::tcl_platform(platform) 10if {$thisPlatform eq "unix" && [tk windowingsystem] eq "aqua"} { 11 set thisPlatform "macosx" 12} 13 14switch -- [tk windowingsystem] { 15 aqua { set thisPlatform "macosx" } 16 classic { set thisPlatform "macintosh" } 17 win32 { set thisPlatform "windows" } 18 x11 { set thisPlatform "unix" } 19} 20 21proc Platform {args} { 22 if {![llength $args]} { return $::thisPlatform } 23 return [expr {[lsearch -exact $args $::thisPlatform] != -1}] 24} 25 26# Get full pathname to this file 27set ScriptDir [file normalize [file dirname [info script]]] 28 29# Command to create a full pathname in this file's directory 30proc Path {args} { 31 return [file normalize [eval [list file join $::ScriptDir] $args]] 32} 33 34# Create some photo images on demand 35proc InitPics {args} { 36 foreach pattern $args { 37 if {[lsearch [image names] $pattern] == -1} { 38 foreach file [glob -directory [Path pics] $pattern.gif] { 39 set imageName [file root [file tail $file]] 40 # I created an image called "file", which clobbered the 41 # original Tcl command "file". Then I got confused. 42 if {[llength [info commands $imageName]]} { 43 error "don't want to create image called \"$imageName\"" 44 } 45 image create photo $imageName -file $file 46 47 # Hack -- Create a "selected" version too 48 image create photo ${imageName}Sel 49 ${imageName}Sel copy $imageName 50 imagetint ${imageName}Sel $::SystemHighlight 128 51 } 52 } 53 } 54 return 55} 56 57# http://wiki.tcl.tk/1530 58if {[info procs lassign] eq ""} { 59 proc lassign {values args} { 60 uplevel 1 [list foreach $args [linsert $values end {}] break] 61 lrange $values [llength $args] end 62 } 63} 64 65if {[catch { 66 package require dbwin 67}]} { 68 proc dbwin {s} { 69 puts [string trimright $s "\n"] 70 } 71} 72proc dbwintrace {name1 name2 op} { 73 dbwin $::dbwin 74} 75trace add variable ::dbwin write dbwintrace 76 77# This gets called if 'package require' won't work during development. 78proc LoadSharedLibrary {} { 79 80 switch -- $::thisPlatform { 81 macintosh { 82 set pattern treectrl*.shlb 83 } 84 macosx { 85 set pattern treectrl*.dylib 86 } 87 unix { 88 set pattern libtreectrl*[info sharedlibextension]* 89 } 90 windows { 91 set pattern treectrl*[info sharedlibextension] 92 } 93 } 94 95 set SHLIB [glob -nocomplain -directory [Path ..] $pattern] 96 if {[llength $SHLIB] != 1} { 97 return 0 98 } 99 100 # When using configure/make, the "make demo" Makefile target sets the value of 101 # the TREECTRL_LIBRARY environment variable which is used by tcl_findLibrary to 102 # find our treectrl.tcl file. When *not* using configure/make, we set the value 103 # of TREECTRL_LIBRARY and load the shared library manually. Note that 104 # tcl_findLibrary is called by the Treectrl_Init() routine in C. 105 set ::env(TREECTRL_LIBRARY) [Path .. library] 106 107 load $SHLIB 108 109 return 1 110} 111 112puts "demo.tcl: Tcl/Tk [info patchlevel] [winfo server .]" 113 114# See if treectrl is already loaded for some reason 115if {[llength [info commands treectrl]]} { 116 puts "demo.tcl: using previously-loaded treectrl package v[package provide treectrl]" 117 if {$VERSION ne [package provide treectrl]} { 118 puts "demo.tcl: WARNING: expected v$VERSION" 119 } 120 121# For 'package require' to work with the development version, make sure the 122# TCLLIBPATH and TREECTRL_LIBRARY environment variables are set by your 123# Makefile/Jamfile/IDE etc. 124} elseif {![catch {package require treectrl $VERSION} err]} { 125 puts "demo.tcl: 'package require' succeeded" 126 127} else { 128 puts "demo.tcl: 'package require' failed: >>> $err <<<" 129 130 if {[LoadSharedLibrary]} { 131 puts "demo.tcl: loaded treectrl library by hand" 132 133 } else { 134 error "demo.tcl: can't load treectrl package" 135 } 136} 137 138# Display path of shared library that was loaded 139foreach list [info loaded] { 140 set file [lindex $list 0] 141 set pkg [lindex $list 1] 142 if {$pkg ne "Treectrl"} continue 143 puts "demo.tcl: using '$file'" 144 break 145} 146if {[info exists env(TREECTRL_LIBRARY)]} { 147 puts "demo.tcl: TREECTRL_LIBRARY=$env(TREECTRL_LIBRARY)" 148} else { 149 puts "demo.tcl: TREECTRL_LIBRARY undefined" 150} 151puts "demo.tcl: treectrl_library=$treectrl_library" 152 153set tile 0 154set tileFull 0 ; # 1 if using tile-aware treectrl 155catch { 156 if {[ttk::style layout TreeCtrl] ne ""} { 157 set tile 1 158 set tileFull 1 159 } 160} 161if {$tile == 0} { 162 catch { 163 package require tile 0.7.8 164 namespace export style 165 namespace eval ::tile { 166 namespace export setTheme 167 } 168 namespace eval ::ttk { 169 namespace import ::style 170 namespace import ::tile::setTheme 171 } 172 set tile 1 173 } 174} 175if {$tile} { 176 # Don't import ttk::entry, it messes up the edit bindings, and I'm not 177 # sure how to get/set the equivalent -borderwidth, -selectborderwidth 178 # etc options of a TEntry. 179 set entryCmd ::ttk::entry 180 set buttonCmd ::ttk::button 181 set checkbuttonCmd ::ttk::checkbutton 182 set radiobuttonCmd ttk::radiobutton 183 set scrollbarCmd ::ttk::scrollbar 184 set scaleCmd ::ttk::scale 185} else { 186 set entryCmd ::entry 187 set buttonCmd ::button 188 set checkbuttonCmd ::checkbutton 189 set radiobuttonCmd ::radiobutton 190 set scrollbarCmd ::scrollbar 191 set scaleCmd ::scale 192} 193 194option add *TreeCtrl.Background white 195#option add *TreeCtrl.itemPrefix item 196#option add *TreeCtrl.ColumnPrefix col 197 198if {$tile} { 199 set font TkDefaultFont 200} else { 201 switch -- $::thisPlatform { 202 macintosh { 203 set font {Geneva 9} 204 } 205 macosx { 206 set font {{Lucida Grande} 13} 207 } 208 unix { 209 set font {Helvetica -12} 210 } 211 default { 212 # There is a bug on my Win98 box with Tk_MeasureChars() and 213 # MS Sans Serif 8. 214 set font {{MS Sans} 8} 215 } 216 } 217} 218array set fontInfo [font actual $font] 219eval font create DemoFont [array get fontInfo] 220option add *TreeCtrl.font DemoFont 221 222array set fontInfo [font actual $font] 223set fontInfo(-weight) bold 224eval font create DemoFontBold [array get fontInfo] 225 226array set fontInfo [font actual $font] 227set fontInfo(-underline) 1 228eval font create DemoFontUnderline [array get fontInfo] 229 230proc SetDemoFontSize {size} { 231 font configure DemoFont -size $size 232 font configure DemoFontBold -size $size 233 font configure DemoFontUnderline -size $size 234 return 235} 236proc IncreaseFontSize {} { 237 set size [font configure DemoFont -size] 238 if {$size < 0} { 239 incr size -1 240 } else { 241 incr size 242 } 243 SetDemoFontSize $size 244 return 245} 246proc DecreaseFontSize {} { 247 set size [font configure DemoFont -size] 248 if {$size < 0} { 249 incr size 250 } else { 251 incr size -1 252 } 253 SetDemoFontSize $size 254 return 255} 256 257# Demo sources 258foreach file { 259 biglist 260 bitmaps 261 column-lock 262 explorer 263 firefox 264 gradients 265 gradients2 266 gradients3 267 headers 268 help 269 imovie 270 layout 271 mailwasher 272 mycomputer 273 outlook-folders 274 outlook-newgroup 275 random 276 span 277 table 278 textvariable 279 www-options 280} { 281 source [Path $file.tcl] 282} 283 284# Get default colors 285set w [listbox .listbox] 286set SystemButtonFace [$w cget -highlightbackground] 287set SystemHighlight [$w cget -selectbackground] 288set SystemHighlightText [$w cget -selectforeground] 289destroy $w 290 291if {$thisPlatform == "unix"} { 292 # I hate that gray selection color 293 set SystemHighlight #316ac5 294 set SystemHighlightText White 295} 296 297proc MakeMenuBar {} { 298 set m [menu .menubar] 299 . configure -menu $m 300 set m2 [menu $m.mFile -tearoff no] 301 if {$::thisPlatform ne "unix" && [info commands console] ne ""} { 302 console eval { 303 wm title . "TkTreeCtrl Console" 304 if {[info tclversion] == 8.4} { 305 .console configure -font {Courier 9} 306 } 307 .console configure -height 8 308# ::tk::ConsolePrompt 309 wm geometry . +0-100 310 } 311 $m2 add command -label "Console" -command { 312 if {[console eval {winfo ismapped .}]} { 313 console hide 314 } else { 315 console show 316 } 317 } 318 } else { 319# uplevel #0 source ~/Programming/console.tcl 320 } 321 $m2 add command -label "Event Browser" -command EventsWindow::ToggleWindowVisibility 322 $m2 add command -label "Identify" -command IdentifyWindow::ToggleWindowVisibility 323 $m2 add command -label "Style Editor" -command ToggleStyleEditorWindow 324 $m2 add command -label "View Source" -command SourceWindow::ToggleWindowVisibility 325 $m2 add command -label "Magnifier" -command LoupeWindow::ToggleWindowVisibility 326 $m2 add separator 327 $m2 add checkbutton -label "Native Gradients" -command ToggleNativeGradients \ 328 -variable ::NativeGradients 329 $m2 add separator 330 $m2 add command -label "Increase Font Size" -command IncreaseFontSize 331 $m2 add command -label "Decrease Font Size" -command DecreaseFontSize 332 switch -- [Platform] { 333 macintosh - 334 macosx { 335 $m add cascade -label "TkTreeCtrl" -menu $m2 336 } 337 unix - 338 windows { 339 $m2 add separator 340 $m2 add command -label "Quit" -command exit 341 $m add cascade -label "File" -menu $m2 342 } 343 } 344 345 if {$::tile} { 346 set m2 [menu $m.mTheme -tearoff no] 347 $m add cascade -label "Theme" -menu $m2 348 foreach theme [lsort -dictionary [ttk::style theme names]] { 349 $m2 add radiobutton -label $theme -command [list ttk::setTheme $theme] \ 350 -variable ::DemoTheme -value $theme 351 } 352 $m2 add separator 353 $m2 add command -label "Inspector" -command ThemeWindow::ToggleWindowVisibility 354 } 355 356 return 357} 358 359namespace eval EventsWindow {} 360 361proc EventsWindow::Init {} { 362 set w [toplevel .events] 363 wm withdraw $w 364# wm transient $w . 365 wm title $w "TkTreeCtrl Events" 366 367 set m [menu $w.menubar] 368 $w configure -menu $m 369 set m1 [menu $m.m1 -tearoff 0] 370 $m1 add cascade -label "Static" -menu [menu $m1.m1 -tearoff 0] 371 $m1 add cascade -label "Dynamic" -menu [menu $m1.m2 -tearoff 0] 372 $m1 add command -label "Clear Window" -command "$w.f.t item delete all" \ 373 -accelerator Ctrl+X 374 $m1 add command -label "Rebuild Menus" -command "EventsWindow::RebuildMenus $w.f.t $m" 375 $m add cascade -label "Events" -menu $m1 376 377 bind $w <Control-KeyPress-x> "$w.f.t item delete all" 378 379 TreePlusScrollbarsInAFrame $w.f 1 1 380 pack $w.f -expand yes -fill both 381 382 set T $w.f.t 383 384 $T configure -showheader no -showroot no -showrootlines no -height 300 385 $T column create -tags C0 386 $T configure -treecolumn C0 387 388 $T element create e1 text -fill [list $::SystemHighlightText {selected focus}] 389 $T element create e2 text -fill [list $::SystemHighlightText {selected focus}] 390 $T element create e3 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ 391 -showfocus yes 392 $T element create e4 rect -fill blue -width 100 -height 2 393 394 set S [$T style create s1] 395 $T style elements $S {e3 e1} 396 $T style layout $S e3 -union [list e1] -ipadx 1 -ipady {0 1} 397 398 set S [$T style create s2] 399 $T style elements $S {e3 e1 e2} 400 $T style layout $S e1 -width 20 -sticky w 401 $T style layout $S e3 -union [list e1 e2] -ipadx 1 -ipady {0 1} 402 403 set S [$T style create s3] 404 $T style elements $S {e4} 405 406 $T column configure C0 -itemstyle s1 407 408 RebuildMenus $T $m 409 410 wm protocol $w WM_DELETE_WINDOW "EventsWindow::ToggleWindowVisibility" 411 switch -- $::thisPlatform { 412 macintosh - 413 macosx { 414 wm geometry $w -40+40 415 } 416 default { 417 wm geometry $w -0+0 418 } 419 } 420 421 return 422} 423 424proc EventsWindow::RebuildMenus {T m} { 425 variable Priv 426 foreach event [lsort -dictionary [[DemoList] notify eventnames]] { 427 set details [lsort -dictionary [[DemoList] notify detailnames $event]] 428 foreach detail $details { 429 set pattern <$event-$detail> 430 set linkage [[DemoList] notify linkage $pattern] 431 lappend patterns $pattern $linkage 432 lappend patterns2($linkage) $pattern 433 } 434 if {![llength $details]} { 435 set pattern <$event> 436 set linkage [[DemoList] notify linkage $pattern] 437 lappend patterns $pattern $linkage 438 lappend patterns2($linkage) $pattern 439 } 440 } 441 442 $m.m1.m1 delete 0 end 443 $m.m1.m2 delete 0 end 444 set menu(static) $m.m1.m1 445 set menu(dynamic) $m.m1.m2 446 foreach {pattern linkage} $patterns { 447 if {![info exists Priv(track,$pattern)]} { 448 set Priv(track,$pattern) 1 449 } 450 $menu($linkage) add checkbutton -label $pattern \ 451 -variable ::EventsWindow::Priv(track,$pattern) \ 452 -command [list EventsWindow::ToggleEvent $T $pattern] 453 } 454 foreach linkage {static dynamic} { 455 $menu($linkage) add separator 456 $menu($linkage) add command -label "Toggle All" \ 457 -command [list EventsWindow::ToggleEvents $T $patterns2($linkage)] 458 } 459 460 set Priv(events) {} 461 set Priv(afterId) "" 462 foreach {pattern linkage} $patterns { 463 [DemoList] notify bind $T $pattern { 464 EventsWindow::EventBinding %W %? 465 } 466 } 467 return 468} 469 470proc EventsWindow::EventBinding {T charMap} { 471 variable Priv 472 lappend Priv(events) $charMap 473 if {$Priv(afterId) eq ""} { 474 set Priv(afterId) [after idle [list EventsWindow::RecordEvents $T]] 475 } 476 return 477} 478 479proc EventsWindow::RecordEvents {T} { 480 variable Priv 481 set Priv(afterId) "" 482 set events $Priv(events) 483 set Priv(events) {} 484 if {![winfo ismapped .events]} return 485 if {[$T item numchildren root] > 2000} { 486 set N [expr {[$T item numchildren root] - 2000}] 487 $T item delete "root firstchild" "root child $N" 488 } 489 if {0 && [$T item count] > 1} { 490 set I [$T item create] 491 $T item style set $I 0 s3 492 $T item lastchild root $I 493 } 494 set open 1 495 if {[llength $events] > 50} { 496 set open 0 497 } 498 foreach list $events { 499 RecordEvent $T $list $open 500 } 501 $T see "last visible" 502 return 503} 504 505proc EventsWindow::RecordEvent {T list open} { 506 set I [$T item create -open $open] 507 array set map $list 508 $T item text $I C0 $map(P) 509 $T item lastchild root $I 510 foreach {char value} $list { 511 if {[string first $char "TWPed"] != -1} continue 512 set I2 [$T item create] 513 $T item style set $I2 C0 s2 514 $T item element configure $I2 C0 e1 -text $char + e2 -text $value 515 $T item lastchild $I $I2 516 $T item configure $I -button yes 517 } 518 return 519} 520 521proc EventsWindow::ToggleWindowVisibility {} { 522 set w .events 523 if {![winfo exists $w]} { 524 Init 525 } 526 if {[winfo ismapped $w]} { 527 wm withdraw $w 528 } else { 529 wm deiconify $w 530 raise $w 531 } 532 return 533} 534 535proc EventsWindow::ToggleEvent {T pattern} { 536 variable Priv 537 [DemoList] notify configure $T $pattern -active $Priv(track,$pattern) 538 return 539} 540 541proc EventsWindow::ToggleEvents {T patterns} { 542 variable Priv 543 foreach pattern $patterns { 544 set Priv(track,$pattern) [expr {!$Priv(track,$pattern)}] 545 ToggleEvent $T $pattern 546 } 547 return 548} 549 550namespace eval IdentifyWindow {} 551 552proc IdentifyWindow::Init {} { 553 set w .identify 554 toplevel $w 555 wm withdraw $w 556 wm title $w "TkTreeCtrl Identify" 557 set wText $w.text 558 text $wText -state disabled -width 70 -height 3 -font [[DemoList] cget -font] 559 $wText tag configure tagBold -font DemoFontBold 560 pack $wText -expand yes -fill both 561 wm protocol $w WM_DELETE_WINDOW "IdentifyWindow::ToggleWindowVisibility" 562 return 563} 564 565proc IdentifyWindow::Update {T x y} { 566 set w .identify 567 if {![winfo exists $w]} return 568 if {![winfo ismapped $w]} return 569 set wText $w.text 570 $wText configure -state normal 571 $wText delete 1.0 end 572 set nearest [$T item id [list nearest $x $y]] 573 $wText insert end "x=" tagBold "$x " {} "y=" tagBold "$y " {} "nearest=" tagBold $nearest\n 574 $wText insert end "string: " 575 foreach {key val} [$T identify $x $y] { 576 $wText insert end $key tagBold " $val " 577 } 578 $wText insert end "\narray: " 579 $T identify -array id $x $y 580 switch -- $id(where) { 581 "header" { 582 set keys [list where header column element side] 583 } 584 "item" { 585 set keys [list where item column element button line] 586 } 587 default { 588 set keys [array names id] 589 } 590 } 591 foreach key $keys { 592 set val $id($key) 593 if {$val eq ""} { 594 set val "\"\"" 595 } 596 $wText insert end $key tagBold " $val " 597 } 598 $wText configure -state disabled 599 return 600} 601 602proc IdentifyWindow::ToggleWindowVisibility {} { 603 set w .identify 604 if {![winfo exists $w]} { 605 Init 606 } 607 if {[winfo ismapped $w]} { 608 wm withdraw $w 609 } else { 610 wm deiconify $w 611 raise $w 612 } 613 return 614} 615 616namespace eval SourceWindow {} 617 618proc SourceWindow::Init {} { 619 set w [toplevel .source] 620 wm withdraw $w 621# wm transient $w . 622 set f [frame $w.f -borderwidth 0] 623 if {[lsearch -exact [font names] TkFixedFont] != -1} { 624 set font TkFixedFont 625 } else { 626 switch -- $::thisPlatform { 627 macintosh - 628 macosx { 629 set font {Geneva 9} 630 } 631 unix { 632 set font {Courier -12} 633 } 634 default { 635 set font {Courier 9} 636 } 637 } 638 } 639 text $f.t -font $font -tabs [font measure $font 12345678] -wrap none \ 640 -yscrollcommand "$f.sv set" -xscrollcommand "$f.sh set" 641 $::scrollbarCmd $f.sv -orient vertical -command "$f.t yview" 642 $::scrollbarCmd $f.sh -orient horizontal -command "$f.t xview" 643 pack $f -expand yes -fill both 644 grid columnconfigure $f 0 -weight 1 645 grid rowconfigure $f 0 -weight 1 646 grid configure $f.t -row 0 -column 0 -sticky news 647 grid configure $f.sh -row 1 -column 0 -sticky we 648 grid configure $f.sv -row 0 -column 1 -sticky ns 649 650 wm protocol $w WM_DELETE_WINDOW "SourceWindow::ToggleWindowVisibility" 651 switch -- $::thisPlatform { 652 macintosh - 653 macosx { 654 wm geometry $w +0+30 655 } 656 default { 657 wm geometry $w -0+0 658 } 659 } 660 661 return 662} 663 664proc SourceWindow::ShowSource {file} { 665 wm title .source "TkTreeCtrl Source: $file" 666 set path [Path $file] 667 set t .source.f.t 668 set chan [open $path] 669 $t delete 1.0 end 670 $t insert end [read $chan] 671 $t mark set insert 1.0 672 close $chan 673 return 674} 675 676proc SourceWindow::ToggleWindowVisibility {} { 677 set w .source 678 if {[winfo ismapped $w]} { 679 wm withdraw $w 680 } else { 681 wm deiconify $w 682 raise $w 683 } 684 return 685} 686 687proc ToggleStyleEditorWindow {} { 688 set w .styleEditor 689 if {![winfo exists $w]} { 690 source [Path style-editor.tcl] 691 StyleEditor::Init [DemoList] 692 StyleEditor::SetListOfStyles 693 } elseif {[winfo ismapped $w]} { 694 wm withdraw $w 695 } else { 696 wm deiconify $w 697 raise $w 698 StyleEditor::SetListOfStyles 699 } 700 return 701} 702 703namespace eval ThemeWindow {} 704proc ThemeWindow::Init {} { 705 set w [toplevel .theme] 706 wm withdraw $w 707# wm transient $w . 708 wm title $w "TkTreeCtrl Themes" 709 710 set m [menu $w.menubar] 711 $w configure -menu $m 712 set m1 [menu $m.m1 -tearoff 0] 713 $m1 add command -label "Set List" -command ThemeWindow::SetList 714 $m add cascade -label "Theme" -menu $m1 715 716 TreePlusScrollbarsInAFrame $w.f 1 1 717 pack $w.f -expand yes -fill both 718 719 set T $w.f.t 720 721 $T configure -showheader no -showroot no -showrootlines no -height 300 722 $T column create -tags C0 723 $T configure -treecolumn C0 724 725 $T element create e1 text -fill [list $::SystemHighlightText {selected focus}] 726 $T element create e3 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ 727 -showfocus yes 728 729 set S [$T style create s1] 730 $T style elements $S {e3 e1} 731 $T style layout $S e3 -union [list e1] -ipadx 1 -ipady {0 1} 732 733 $T column configure C0 -itemstyle s1 734 735 SetList 736 737 wm protocol $w WM_DELETE_WINDOW "ThemeWindow::ToggleWindowVisibility" 738 739 return 740} 741 742proc ThemeWindow::ToggleWindowVisibility {} { 743 set w .theme 744 if {![winfo exists $w]} { 745 Init 746 } 747 if {[winfo ismapped $w]} { 748 wm withdraw $w 749 } else { 750 wm deiconify $w 751 raise $w 752 } 753 return 754} 755 756proc ThemeWindow::SetList {} { 757 set w .theme 758 set T $w.f.t 759 760 $T item delete all 761 # 762 # Themes 763 # 764 foreach theme [lsort -dictionary [ttk::style theme names]] { 765 set I [$T item create -button yes -open no -tags theme -parent root] 766 $T item text $I C0 $theme 767 ttk::style theme settings $theme { 768 set I2 [$T item create -button yes -open no -parent $I] 769 $T item text $I2 C0 ELEMENTS 770 # 771 # Elements 772 # 773 foreach element [lsort -dictionary [ttk::style element names]] { 774 # 775 # Element options 776 # 777 set options [ttk::style element options $element] 778 set I3 [$T item create -button [llength $options] -open no -tags element -parent $I2] 779 $T item text $I3 C0 $element 780 foreach option [lsort -dictionary $options] { 781 set I4 [$T item create -open no -tags {element option} -parent $I3] 782 $T item text $I4 C0 $option 783 } 784 } 785 # 786 # Styles 787 # 788 set I2 [$T item create -button yes -open no -parent $I] 789 $T item text $I2 C0 STYLES 790 set styles [list "."] ; # [ttk::style names] please! 791 foreach style [lsort -dictionary $styles] { 792 # 793 # Style options 794 # 795 set cfg [ttk::style configure $style] 796 set I3 [$T item create -button [llength $cfg] -open no -tags style -parent $I2] 797 $T item text $I3 C0 $style 798 foreach {option value} $cfg { 799 set I4 [$T item create -open no -tags {style option} -parent $I3] 800 $T item text $I4 C0 "$option $value" 801 } 802 } 803 } 804 } 805 return 806} 807 808set ::NativeGradients 1 809proc ToggleNativeGradients {} { 810 [DemoList] gradient native $::NativeGradients 811 dbwin "native gradients is now $::NativeGradients" 812 return 813} 814 815SourceWindow::Init 816MakeMenuBar 817 818# http://wiki.tcl.tk/950 819proc sbset {sb first last} { 820 # Get infinite loop on X11 821 if {$::thisPlatform ne "unix"} { 822 if {$first <= 0 && $last >= 1} { 823 grid remove $sb 824 } else { 825 grid $sb 826 } 827 } 828 $sb set $first $last 829 return 830} 831 832proc TreePlusScrollbarsInAFrame {f h v} { 833 if {$::tileFull} { 834 frame $f -borderwidth 0 835 } else { 836 frame $f -borderwidth 1 -relief sunken 837 } 838 treectrl $f.t -highlightthickness 0 -borderwidth 0 839 if {[Platform unix]} { 840 $f.t configure -headerfont [$f.t cget -font] 841 } 842 $f.t configure -xscrollincrement 20 -xscrollsmoothing 1 843# $f.t configure -itemprefix item# -columnprefix column# 844 $f.t debug configure -enable no -display yes -erasecolor pink \ 845 -drawcolor orange -displaydelay 30 -textlayout 0 -data 0 -span 0 846 if {$h} { 847 $::scrollbarCmd $f.sh -orient horizontal -command "$f.t xview" 848 # $f.t configure -xscrollcommand "$f.sh set" 849 $f.t notify bind $f.sh <Scroll-x> { sbset %W %l %u } 850 bind $f.sh <ButtonPress-1> "focus $f.t" 851 } 852 if {$v} { 853 $::scrollbarCmd $f.sv -orient vertical -command "$f.t yview" 854 # $f.t configure -yscrollcommand "$f.sv set" 855 $f.t notify bind $f.sv <Scroll-y> { sbset %W %l %u } 856 bind $f.sv <ButtonPress-1> "focus $f.t" 857 } 858 grid columnconfigure $f 0 -weight 1 859 grid rowconfigure $f 0 -weight 1 860 grid configure $f.t -row 0 -column 0 -sticky news 861 if {$h} { 862 grid configure $f.sh -row 1 -column 0 -sticky we 863 } 864 if {$v} { 865 grid configure $f.sv -row 0 -column 1 -sticky ns 866 } 867 868 bind $f.t <Control-Shift-ButtonPress-1> { 869 TreeCtrl::MarqueeBegin %W %x %y 870 set DebugExpose(x1) %x 871 set DebugExpose(y1) %y 872 break 873 } 874 bind $f.t <Control-Shift-Button1-Motion> { 875 TreeCtrl::MarqueeUpdate %W %x %y 876 set DebugExpose(x2) %x 877 set DebugExpose(y2) %y 878 break 879 } 880 bind $f.t <Control-Shift-ButtonRelease-1> { 881 TreeCtrl::MarqueeEnd %W %x %y 882 %W debug expose $DebugExpose(x1) $DebugExpose(y1) $DebugExpose(x2) $DebugExpose(y2) 883 break 884 } 885 886 MakeListPopup $f.t 887 MakeHeaderPopup $f.t 888 889 switch -- $::thisPlatform { 890 macintosh - 891 macosx { 892 bind $f.t <Control-ButtonPress-1> { 893 ShowPopup %W %x %y %X %Y 894 } 895 bind $f.t <ButtonPress-2> { 896 ShowPopup %W %x %y %X %Y 897 } 898 } 899 unix - 900 windows { 901 bind $f.t <ButtonPress-3> { 902 ShowPopup %W %x %y %X %Y 903 } 904 } 905 } 906 907 return 908} 909 910proc ShouldShowLines {T} { 911 if {![$T cget -usetheme]} { 912 return 1 913 } 914 switch -- [$T theme platform] { 915 aqua - 916 gtk { 917 return 0 918 } 919 } 920 return 1 921} 922 923proc MakeMainWindow {} { 924 925 wm title . "TkTreeCtrl Demo" 926 927 switch -- $::thisPlatform { 928 macintosh - 929 macosx { 930 wm geometry . +6+30 931 } 932 default { 933 wm geometry . +0+0 934 } 935 } 936 937 panedwindow .pw2 -orient horizontal -borderwidth 0 -sashwidth 6 938 panedwindow .pw1 -orient vertical -borderwidth 0 -sashwidth 6 939 940 # Tree + scrollbar: demos 941 TreePlusScrollbarsInAFrame .f1 1 1 942 .f1.t configure -showbuttons no -showlines no -showroot no -height 100 943 .f1.t column create -text "List of Demos" -expand yes -button no -tags C0 944 .f1.t configure -treecolumn C0 945 946 # Tree + scrollbar: styles + elements in list 947 TreePlusScrollbarsInAFrame .f4 1 1 948 .f4.t configure -showlines [ShouldShowLines .f4.t] -showroot no -height 140 949 .f4.t column create -text "Elements and Styles" -expand yes -button no -tags C0 950 .f4.t configure -treecolumn C0 951 952 # Tree + scrollbar: styles + elements in selected item 953 TreePlusScrollbarsInAFrame .f3 1 1 954 .f3.t configure -showlines [ShouldShowLines .f3.t] -showroot no 955 .f3.t column create -text "Styles in Item" -expand yes -button no -tags C0 956 .f3.t configure -treecolumn C0 957 958 .pw1 add .f1 .f4 .f3 -height 150 959 960 # Frame on right 961 frame .f2 962 963 # Tree + scrollbars 964 TreePlusScrollbarsInAFrame .f2.f1 1 1 965 [DemoList] configure -indent 19 966 967 # Give it a big border to debug drawing 968 if {!$::tileFull} { 969 [DemoList] configure -borderwidth 6 -relief ridge -highlightthickness 3 970 } 971 972 grid columnconfigure .f2 0 -weight 1 973 grid rowconfigure .f2 0 -weight 1 974 grid configure .f2.f1 -row 0 -column 0 -sticky news -pady 0 975 976 # Window to display result of "T identify" 977 bind TagIdentify <Motion> { 978 if {"%W" ne [DemoList]} { 979 set x [expr {%X - [winfo rootx [DemoList]]}] 980 set y [expr {%Y - [winfo rooty [DemoList]]}] 981 } else { 982 set x %x 983 set y %y 984 } 985 IdentifyWindow::Update [DemoList] $x $y 986 } 987 AddBindTag [DemoList] TagIdentify 988 989 .pw2 add .pw1 -width 200 990 .pw2 add .f2 -width 450 991 992 pack .pw2 -expand yes -fill both 993 994 bind [DemoList] <g> { 995 set NativeGradients [expr {!$NativeGradients}] 996 ToggleNativeGradients 997 } 998 999 ### 1000 # A treectrl widget can generate the following built-in events: 1001 # <ActiveItem> called when the active item changes 1002 # <Collapse-before> called before an item is closed 1003 # <Collapse-after> called after an item is closed 1004 # <Expand-before> called before an item is opened 1005 # <Expand-after> called after an item is opened 1006 # <ItemDelete> called before items are deleted 1007 # <Scroll-x> called when horizontal scroll position changes 1008 # <Scroll-y> called when vertical scroll position changes 1009 # <Selection> called when items are added to or removed from the selection 1010 # 1011 # The application programmer can define custom events to be 1012 # generated by the "notify generate" command. The following events 1013 # are generated by the library scripts. 1014 1015 [DemoList] notify install <Header-invoke> 1016 [DemoList] notify install <Header-state> 1017 1018 [DemoList] notify install <ColumnDrag-begin> 1019 [DemoList] notify install <ColumnDrag-end> 1020 [DemoList] notify install <ColumnDrag-indicator> 1021 [DemoList] notify install <ColumnDrag-receive> 1022 1023 [DemoList] notify install <Drag-begin> 1024 [DemoList] notify install <Drag-end> 1025 [DemoList] notify install <Drag-receive> 1026 1027 [DemoList] notify install <Edit-begin> 1028 [DemoList] notify install <Edit-end> 1029 [DemoList] notify install <Edit-accept> 1030 ### 1031 1032 # This event is generated when a column's visibility is changed by 1033 # the context menu. 1034 [DemoList] notify install <DemoColumnVisibility> 1035 1036 return 1037} 1038 1039proc DemoList {} { 1040 return .f2.f1.t 1041} 1042proc demolist args { # console-friendly version 1043 uplevel .f2.f1.t $args 1044} 1045 1046proc MakeListPopup {T} { 1047 set m [menu $T.mTree -tearoff no] 1048 1049 set m2 [menu $m.mCollapse -tearoff no] 1050 $m add cascade -label Collapse -menu $m2 1051 1052 set m2 [menu $m.mExpand -tearoff no] 1053 $m add cascade -label Expand -menu $m2 1054 1055 set m2 [menu $m.mBgImg -tearoff no] 1056 $m2 add radiobutton -label none -variable Popup(bgimg) -value none \ 1057 -command {$Popup(T) configure -backgroundimage ""} 1058 $m2 add radiobutton -label feather -variable Popup(bgimg) -value feather \ 1059 -command {$Popup(T) configure -bgimage $Popup(bgimg) -bgimageopaque no} 1060 $m2 add radiobutton -label sky -variable Popup(bgimg) -value sky \ 1061 -command {$Popup(T) configure -bgimage $Popup(bgimg) -bgimageopaque yes} 1062 $m2 add separator 1063 set m3 [menu $m2.mBgImgAnchor -tearoff no] 1064 foreach anchor {nw n ne w center e sw s se} { 1065 $m3 add radiobutton -label $anchor -variable Popup(bgimganchor) \ 1066 -value $anchor \ 1067 -command {$Popup(T) configure -bgimageanchor $Popup(bgimganchor)} 1068 } 1069 $m2 add cascade -label "Anchor" -menu $m3 1070 $m2 add separator 1071 $m2 add checkbutton -label "Opaque" -variable Popup(bgimgopaque) \ 1072 -command {$Popup(T) configure -bgimageopaque $Popup(bgimgopaque)} 1073 $m2 add separator 1074 $m2 add checkbutton -label "Scroll X" -variable Popup(bgimgscrollx) \ 1075 -onvalue x -offvalue "" -command {$Popup(T) configure -bgimagescroll $Popup(bgimgscrollx)$Popup(bgimgscrolly)} 1076 $m2 add checkbutton -label "Scroll Y" -variable Popup(bgimgscrolly) \ 1077 -onvalue y -offvalue "" -command {$Popup(T) configure -bgimagescroll $Popup(bgimgscrollx)$Popup(bgimgscrolly)} 1078 $m2 add separator 1079 $m2 add checkbutton -label "Tile X" -variable Popup(bgimgtilex) \ 1080 -onvalue x -offvalue "" -command {$Popup(T) configure -bgimagetile $Popup(bgimgtilex)$Popup(bgimgtiley)} 1081 $m2 add checkbutton -label "Tile Y" -variable Popup(bgimgtiley) \ 1082 -onvalue y -offvalue "" -command {$Popup(T) configure -bgimagetile $Popup(bgimgtilex)$Popup(bgimgtiley)} 1083 $m add cascade -label "Background Image" -menu $m2 1084 1085 set m2 [menu $m.mBgMode -tearoff no] 1086 foreach value {column order ordervisible row} { 1087 $m2 add radiobutton -label $value -variable Popup(bgmode) -value $value \ 1088 -command {$Popup(T) configure -backgroundmode $Popup(bgmode)} 1089 } 1090 $m add cascade -label "Background Mode" -menu $m2 1091 1092 $m add checkbutton -label "Button Tracking" -variable Popup(buttontracking) \ 1093 -command {$Popup(T) configure -buttontracking $Popup(buttontracking)} 1094 1095 set m2 [menu $m.mColumns -tearoff no] 1096 $m add cascade -label "Columns" -menu $m2 1097 1098 set m2 [menu $m.mHeaders -tearoff no] 1099 $m add cascade -label "Headers" -menu $m2 1100 1101 set m2 [menu $m.mColumnResizeMode -tearoff no] 1102 $m2 add radiobutton -label proxy -variable Popup(columnresizemode) -value proxy \ 1103 -command {$Popup(T) configure -columnresizemode $Popup(columnresizemode)} 1104 $m2 add radiobutton -label realtime -variable Popup(columnresizemode) -value realtime \ 1105 -command {$Popup(T) configure -columnresizemode $Popup(columnresizemode)} 1106 $m add cascade -label "Column Resize Mode" -menu $m2 1107 1108 set m2 [menu $m.mDebug -tearoff no] 1109 $m2 add checkbutton -label Data -variable Popup(debug,data) \ 1110 -command {$Popup(T) debug configure -data $Popup(debug,data)} 1111 $m2 add checkbutton -label Display -variable Popup(debug,display) \ 1112 -command {$Popup(T) debug configure -display $Popup(debug,display)} 1113 $m2 add checkbutton -label Span -variable Popup(debug,span) \ 1114 -command {$Popup(T) debug configure -span $Popup(debug,span)} 1115 $m2 add checkbutton -label "Text Layout" -variable Popup(debug,textlayout) \ 1116 -command {$Popup(T) debug configure -textlayout $Popup(debug,textlayout)} 1117 $m2 add separator 1118 set m3 [menu $m2.mDelay -tearoff no] 1119 foreach n {10 20 30 40 50 60 70 80 90 100} { 1120 $m3 add radiobutton -label $n -variable Popup(debug,displaydelay) -value $n \ 1121 -command {$Popup(T) debug configure -displaydelay $Popup(debug,displaydelay)} 1122 } 1123 $m2 add cascade -label "Display Delay" -menu $m3 1124 $m2 add separator 1125 $m2 add checkbutton -label Enable -variable Popup(debug,enable) \ 1126 -command {$Popup(T) debug configure -enable $Popup(debug,enable)} 1127 $m add cascade -label Debug -menu $m2 1128if 0 { 1129 set m2 [menu $m.mBuffer -tearoff no] 1130 $m2 add radiobutton -label "none" -variable Popup(doublebuffer) -value none \ 1131 -command {$Popup(T) configure -doublebuffer $Popup(doublebuffer)} 1132 $m2 add radiobutton -label "item" -variable Popup(doublebuffer) -value item \ 1133 -command {$Popup(T) configure -doublebuffer $Popup(doublebuffer)} 1134 $m2 add radiobutton -label "window" -variable Popup(doublebuffer) -value window \ 1135 -command {$Popup(T) configure -doublebuffer $Popup(doublebuffer)} 1136 $m add cascade -label Buffering -menu $m2 1137} 1138 set m2 [menu $m.mItemWrap -tearoff no] 1139 $m add cascade -label "Item Wrap" -menu $m2 1140 1141 set m2 [menu $m.mLineStyle -tearoff no] 1142 $m2 add radiobutton -label "dot" -variable Popup(linestyle) -value dot \ 1143 -command {$Popup(T) configure -linestyle $Popup(linestyle)} 1144 $m2 add radiobutton -label "solid" -variable Popup(linestyle) -value solid \ 1145 -command {$Popup(T) configure -linestyle $Popup(linestyle)} 1146 $m add cascade -label "Line style" -menu $m2 1147 1148 set m2 [menu $m.mOrient -tearoff no] 1149 $m2 add radiobutton -label "Horizontal" -variable Popup(orient) -value horizontal \ 1150 -command {$Popup(T) configure -orient $Popup(orient)} 1151 $m2 add radiobutton -label "Vertical" -variable Popup(orient) -value vertical \ 1152 -command {$Popup(T) configure -orient $Popup(orient)} 1153 $m add cascade -label Orient -menu $m2 1154 1155 set m2 [menu $m.mSmoothing -tearoff no] 1156 $m2 add checkbutton -label X -variable Popup(xscrollsmoothing) \ 1157 -command {$Popup(T) configure -xscrollsmoothing $Popup(xscrollsmoothing)} 1158 $m2 add checkbutton -label Y -variable Popup(yscrollsmoothing) \ 1159 -command {$Popup(T) configure -yscrollsmoothing $Popup(yscrollsmoothing)} 1160 $m add cascade -label "Scroll Smoothing" -menu $m2 1161 1162 set m2 [menu $m.mSelectMode -tearoff no] 1163 foreach mode [list browse extended multiple single] { 1164 $m2 add radiobutton -label $mode -variable Popup(selectmode) -value $mode \ 1165 -command {$Popup(T) configure -selectmode $Popup(selectmode)} 1166 } 1167 $m add cascade -label Selectmode -menu $m2 1168 1169 set m2 [menu $m.mShow -tearoff no] 1170 $m2 add checkbutton -label "Buttons" -variable Popup(showbuttons) \ 1171 -command {$Popup(T) configure -showbuttons $Popup(showbuttons)} 1172 $m2 add checkbutton -label "Header" -variable Popup(showheader) \ 1173 -command {$Popup(T) configure -showheader $Popup(showheader)} 1174 $m2 add checkbutton -label "Lines" -variable Popup(showlines) \ 1175 -command {$Popup(T) configure -showlines $Popup(showlines)} 1176 $m2 add checkbutton -label "Root" -variable Popup(showroot) \ 1177 -command {$Popup(T) configure -showroot $Popup(showroot)} 1178 $m2 add checkbutton -label "Root Button" -variable Popup(showrootbutton) \ 1179 -command {$Popup(T) configure -showrootbutton $Popup(showrootbutton)} 1180 $m2 add checkbutton -label "Root Child Buttons" -variable Popup(showrootchildbuttons) \ 1181 -command {$Popup(T) configure -showrootchildbuttons $Popup(showrootchildbuttons)} 1182 $m2 add checkbutton -label "Root Child Lines" -variable Popup(showrootlines) \ 1183 -command {$Popup(T) configure -showrootlines $Popup(showrootlines)} 1184 $m add cascade -label Show -menu $m2 1185 1186 set m2 [menu $m.mSpan -tearoff no] 1187 $m add cascade -label Span -menu $m2 1188 1189 $m add checkbutton -label "Use Theme" -variable Popup(usetheme) \ 1190 -command {$Popup(T) configure -usetheme $Popup(usetheme)} 1191 1192 return 1193} 1194 1195proc MakeHeaderPopup {T} { 1196 set m [menu $T.mColumn -tearoff no] 1197 1198 ### Header 1199 1200 set m1 [menu $m.mHeader -tearoff no] 1201 $m add cascade -label "Header" -menu $m1 1202 1203 $m1 add checkbutton -label "Visible" -variable Popup(header,visible) \ 1204 -command [list eval $T header configure \$Popup(header) -visible \$Popup(header,visible)] 1205 1206 set m2 [menu $m1.mDnD -tearoff no] 1207 $m1 add cascade -label "Drag and Drop" -menu $m2 1208 $m2 add checkbutton -label "Draw" -variable Popup(header,drag,draw) \ 1209 -command [list eval $T header dragconfigure \$Popup(header) -draw \$Popup(header,drag,draw)] 1210 $m2 add checkbutton -label "Enable" -variable Popup(header,drag,enable) \ 1211 -command [list eval $T header dragconfigure \$Popup(header) -enable \$Popup(header,drag,enable)] 1212 1213 ### Header column 1214 1215 set m1 [menu $m.mHeaderColumn -tearoff no] 1216 $m add cascade -label "Header Column" -menu $m1 1217 1218 set m2 [menu $m1.mArrow -tearoff no] 1219 $m1 add cascade -label Arrow -menu $m2 1220 $m2 add radiobutton -label "None" -variable Popup(arrow) -value none \ 1221 -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrow none} 1222 $m2 add radiobutton -label "Up" -variable Popup(arrow) -value up \ 1223 -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrow up} 1224 $m2 add radiobutton -label "Down" -variable Popup(arrow) -value down \ 1225 -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrow down} 1226 $m2 add separator 1227 $m2 add radiobutton -label "Side Left" -variable Popup(arrow,side) -value left \ 1228 -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrowside left} 1229 $m2 add radiobutton -label "Side Right" -variable Popup(arrow,side) -value right \ 1230 -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrowside right} 1231 $m2 add separator 1232 $m2 add radiobutton -label "Gravity Left" -variable Popup(arrow,gravity) -value left \ 1233 -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrowgravity left} 1234 $m2 add radiobutton -label "Gravity Right" -variable Popup(arrow,gravity) -value right \ 1235 -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrowgravity right} 1236 1237 $m1 add checkbutton -label "Button" -variable Popup(button) \ 1238 -command {$Popup(T) header configure $Popup(header) $Popup(column) -button $Popup(button)} 1239 1240 set m2 [menu $m1.mJustify -tearoff no] 1241 $m1 add cascade -label "Justify" -menu $m2 1242 $m2 add radiobutton -label "Left" -variable Popup(header,justify) -value left \ 1243 -command {$Popup(T) header configure $Popup(header) $Popup(column) -justify left} 1244 $m2 add radiobutton -label "Center" -variable Popup(header,justify) -value center \ 1245 -command {$Popup(T) header configure $Popup(header) $Popup(column) -justify center} 1246 $m2 add radiobutton -label "Right" -variable Popup(header,justify) -value right \ 1247 -command {$Popup(T) header configure $Popup(header) $Popup(column) -justify right} 1248 1249 set m2 [menu $m1.mSpan -tearoff no] 1250 $m1 add cascade -label Span -menu $m2 1251 1252 ### Tree column 1253 $m add command -label "Column" 1254 1255 return 1256} 1257 1258proc MakeHeaderSubmenu {T H parentMenu} { 1259 1260 ### Header 1261 1262 set m1 [menu $parentMenu.mHeader$H -tearoff no] 1263 1264 $m1 add checkbutton -label "Visible" -variable Popup(header,visible,$H) \ 1265 -command [list eval $T header configure $H -visible \$Popup(header,visible,$H)] 1266 1267 return $m1 1268} 1269 1270proc MakeColumnSubmenu {T C parentMenu {menuName ""}} { 1271 1272 ### Tree-column 1273if 1 { 1274 if {$menuName ne ""} { 1275 set m1 [menu $parentMenu.mColumn$menuName -tearoff no] 1276 } else { 1277 set m1 [menu $parentMenu.mColumn$C -tearoff no] 1278 } 1279} else { 1280 set m1 $parentMenu.mColumn$C 1281 $m1 delete 0 end 1282} 1283 $m1 add checkbutton -label "Expand" -variable Popup(column,expand,$C) \ 1284 -command [list eval $T column configure $C -expand \$Popup(column,expand,$C)] 1285 1286 set m2 [menu $m1.mItemJustify -tearoff no] 1287 $m1 add cascade -label "Item Justify" -menu $m2 1288 $m2 add radiobutton -label "Left" -variable Popup(column,itemjustify,$C) -value left \ 1289 -command [list $T column configure $C -itemjustify left] 1290 $m2 add radiobutton -label "Center" -variable Popup(column,itemjustify,$C) -value center \ 1291 -command [list $T column configure $C -itemjustify center] 1292 $m2 add radiobutton -label "Right" -variable Popup(column,itemjustify,$C) -value right \ 1293 -command [list $T column configure $C -itemjustify right] 1294 $m2 add radiobutton -label "Unspecified" -variable Popup(column,itemjustify,$C) -value none \ 1295 -command [list $T column configure $C -itemjustify {}] 1296 1297 set m2 [menu $m1.mJustify -tearoff no] 1298 $m1 add cascade -label "Justify" -menu $m2 1299 $m2 add radiobutton -label "Left" -variable Popup(column,justify,$C) -value left \ 1300 -command [list $T column configure $C -justify left] 1301 $m2 add radiobutton -label "Center" -variable Popup(column,justify,$C) -value center \ 1302 -command [list $T column configure $C -justify center] 1303 $m2 add radiobutton -label "Right" -variable Popup(column,justify,$C) -value right \ 1304 -command [list $T column configure $C -justify right] 1305 1306 set m2 [menu $m1.mLock -tearoff no] 1307 $m1 add cascade -label Lock -menu $m2 1308 $m2 add radiobutton -label "Left" -variable Popup(column,lock,$C) -value left \ 1309 -command [list $T column configure $C -lock left] 1310 $m2 add radiobutton -label "None" -variable Popup(column,lock,$C) -value none \ 1311 -command [list $T column configure $C -lock none] 1312 $m2 add radiobutton -label "Right" -variable Popup(column,lock,$C) -value right \ 1313 -command [list $T column configure $C -lock right] 1314 1315 $m1 add checkbutton -label "Resize" -variable Popup(column,resize,$C) \ 1316 -command [list eval $T column configure $C -resize \$Popup(column,resize,$C)] 1317 $m1 add checkbutton -label "Squeeze" -variable Popup(column,squeeze,$C) \ 1318 -command [list eval $T column configure $C -squeeze \$Popup(column,squeeze,$C)] 1319 $m1 add checkbutton -label "Tree Column" -variable Popup(column,treecolumn,$C) \ 1320 -command [list eval $T configure -treecolumn "\[expr {\$Popup(column,treecolumn,$C) ? $C : {}}\]"] 1321 $m1 add checkbutton -label "Visible" -variable Popup(column,visible,$C) \ 1322 -command [list eval $T column configure $C -visible \$Popup(column,visible,$C) \; \ 1323 TreeCtrl::TryEvent $T DemoColumnVisibility {} [list C $C] ] 1324 1325 return $m1 1326} 1327 1328proc AddBindTag {w tag} { 1329 1330 if {[lsearch -exact [bindtags $w] $tag] == -1} { 1331 bindtags $w [concat [bindtags $w] $tag] 1332 } 1333 foreach child [winfo children $w] { 1334 AddBindTag $child $tag 1335 } 1336 return 1337} 1338 1339MakeMainWindow 1340 1341InitPics sky feather 1342 1343proc ShowPopup {T x y X Y} { 1344 global Popup 1345 set Popup(T) $T 1346 $T identify -array id $x $y 1347 if {$id(where) ne ""} { 1348 if {$id(where) eq "header"} { 1349 set H $id(header) 1350 set C $id(column) 1351 set Popup(header) $H 1352 set Popup(column) $C 1353 set Popup(arrow) [$T header cget $H $C -arrow] 1354 set Popup(arrow,side) [$T header cget $H $C -arrowside] 1355 set Popup(arrow,gravity) [$T header cget $H $C -arrowgravity] 1356 set Popup(button) [$T header cget $H $C -button] 1357 set Popup(header,justify) [$T header cget $H $C -justify] 1358 set Popup(header,visible) [$T header cget $H -visible] 1359 1360 set Popup(header,drag,draw) [$T header dragcget $H -draw] 1361 set Popup(header,drag,enable) [$T header dragcget $H -enable] 1362 1363 set Popup(column,expand,$C) [$T column cget $C -expand] 1364 set Popup(column,resize,$C) [$T column cget $C -resize] 1365 set Popup(column,squeeze,$C) [$T column cget $C -squeeze] 1366 set Popup(column,itemjustify,$C) [$T column cget $C -itemjustify] 1367 if {$Popup(column,itemjustify,$C) eq ""} { set Popup(column,itemjustify) none } 1368 set Popup(column,justify,$C) [$T column cget $C -justify] 1369 set Popup(column,lock,$C) [$T column cget $C -lock] 1370 set Popup(column,treecolumn,$C) [expr {[$T column id tree] eq $C}] 1371 $T.mColumn delete "Column" 1372 destroy $T.mColumn.mColumnX 1373 set m1 [MakeColumnSubmenu $T $C $T.mColumn "X"] 1374 $T.mColumn add cascade -label "Column" -menu $m1 1375 1376 set m $T.mColumn.mHeaderColumn.mSpan 1377 $m delete 0 end 1378 if {[$T column compare $C == tail]} { 1379 $m add checkbutton -label 1 -variable Popup(span) 1380 set Popup(span) 1 1381 } else { 1382 set lock [$T column cget $C -lock] 1383 set last [expr {[$T column order "last lock $lock"] - [$T column order $C] + 1}] 1384 for {set i 1} {$i <= $last} {incr i} { 1385 set break [expr {!(($i - 1) % 20)}] 1386 $m add radiobutton -label $i -command "$T header span $H $C $i" \ 1387 -variable Popup(span) -value $i -columnbreak $break 1388 } 1389 set Popup(span) [$T header span $H $C] 1390 } 1391 1392 tk_popup $T.mColumn $X $Y 1393 return 1394 } 1395 } 1396 set menu $T.mTree 1397 set m $menu.mCollapse 1398 $m delete 0 end 1399 $m add command -label "All" -command {$Popup(T) item collapse all} 1400 if {$id(where) eq "item"} { 1401 set item $id(item) 1402 $m add command -label "Item $item" -command "$T item collapse $item" 1403 $m add command -label "Item $item (recurse)" -command "$T item collapse $item -recurse" 1404 } 1405 set m $menu.mExpand 1406 $m delete 0 end 1407 $m add command -label "All" -command {$Popup(T) item expand all} 1408 if {$id(where) eq "item"} { 1409 set item $id(item) 1410 $m add command -label "Item $item" -command "$T item expand $item" 1411 $m add command -label "Item $item (recurse)" -command "$T item expand $item -recurse" 1412 } 1413 foreach option {data display displaydelay enable span textlayout} { 1414 set Popup(debug,$option) [$T debug cget -$option] 1415 } 1416 set Popup(bgimg) [$T cget -backgroundimage] 1417 set Popup(bgimganchor) [$T cget -bgimageanchor] 1418 set Popup(bgimgopaque) [$T cget -bgimageopaque] 1419 set Popup(bgimgscrollx) [string trim [$T cget -bgimagescroll] y] 1420 set Popup(bgimgscrolly) [string trim [$T cget -bgimagescroll] x] 1421 set Popup(bgimgtilex) [string trim [$T cget -bgimagetile] y] 1422 set Popup(bgimgtiley) [string trim [$T cget -bgimagetile] x] 1423 if {$Popup(bgimg) eq ""} { set Popup(bgimg) none } 1424 set Popup(bgmode) [$T cget -backgroundmode] 1425 set Popup(buttontracking) [$T cget -buttontracking] 1426 set Popup(columnresizemode) [$T cget -columnresizemode] 1427 set Popup(doublebuffer) [$T cget -doublebuffer] 1428 set Popup(linestyle) [$T cget -linestyle] 1429 set Popup(orient) [$T cget -orient] 1430 set Popup(selectmode) [$T cget -selectmode] 1431 set Popup(xscrollsmoothing) [$T cget -xscrollsmoothing] 1432 set Popup(yscrollsmoothing) [$T cget -yscrollsmoothing] 1433 set Popup(showbuttons) [$T cget -showbuttons] 1434 set Popup(showheader) [$T cget -showheader] 1435 set Popup(showlines) [$T cget -showlines] 1436 set Popup(showroot) [$T cget -showroot] 1437 set Popup(showrootbutton) [$T cget -showrootbutton] 1438 set Popup(showrootchildbuttons) [$T cget -showrootchildbuttons] 1439 set Popup(showrootlines) [$T cget -showrootlines] 1440 1441 set m $menu.mColumns 1442 eval destroy [winfo children $m] 1443 $m delete 0 end 1444 foreach C [$T column list] { 1445 set break [expr {!([$T column order $C] % 20)}] 1446 set m1 [MakeColumnSubmenu $T $C $m] 1447# set m1 [menu $m.mColumn$C -postcommand [list PostColumnSubmenu $T $C $m]] 1448 $m add cascade -menu $m1 -columnbreak $break \ 1449 -label "Column $C \"[$T column cget $C -text]\" \[[$T column cget $C -image]\]" 1450 1451 set Popup(column,expand,$C) [$T column cget $C -expand] 1452 set Popup(column,justify,$C) [$T column cget $C -justify] 1453 set Popup(column,itemjustify,$C) [$T column cget $C -itemjustify] 1454 if {$Popup(column,itemjustify,$C) eq ""} { set Popup(column,itemjustify,$C) none } 1455 set Popup(column,lock,$C) [$T column cget $C -lock] 1456 set Popup(column,squeeze,$C) [$T column cget $C -squeeze] 1457 set Popup(column,visible,$C) [$T column cget $C -visible] 1458 set Popup(treecolumn,$C) no 1459 if {[$T column id tree] ne ""} { 1460 set Popup(treecolumn,$C) [$T column compare [$T column id tree] == $C] 1461 } 1462 } 1463 1464 set m $menu.mHeaders 1465 eval destroy [winfo children $m] 1466 $m delete 0 end 1467 foreach H [$T header id all] { 1468 set m1 [MakeHeaderSubmenu $T $H $m] 1469 $m add cascade -menu $m1 -label "Header $H" 1470 set Popup(header,visible,$H) [$T header cget $H -visible] 1471 } 1472 1473 set m $menu.mItemWrap 1474 $m delete 0 end 1475 $m add command -label "All Off" -command {$Popup(T) item configure all -wrap off} 1476 $m add command -label "All On" -command {$Popup(T) item configure all -wrap on} 1477 if {$id(where) eq "item"} { 1478 set item $id(item) 1479 if {[$T item cget $item -wrap]} { 1480 $m add command -label "Item $item Off" -command "$T item configure $item -wrap off" 1481 } else { 1482 $m add command -label "Item $item On" -command "$T item configure $item -wrap on" 1483 } 1484 } 1485 1486 set m $menu.mSpan 1487 $m delete 0 end 1488 if {$id(where) eq "item" && $id(column) ne ""} { 1489 set item $id(item) 1490 set column $id(column) 1491 set lock [$T column cget $column -lock] 1492 for {set i 1} {$i <= [$T column order "last lock $lock"] - [$T column order $column] + 1} {incr i} { 1493 set break [expr {!(($i - 1) % 20)}] 1494 $m add radiobutton -label $i -command "$T item span $item $column $i" \ 1495 -variable Popup(span) -value $i -columnbreak $break 1496 } 1497 set Popup(span) [$T item span $item $column] 1498 } else { 1499 $m add command -label "no item column" -state disabled 1500 } 1501 1502 set Popup(usetheme) [$T cget -usetheme] 1503 tk_popup $menu $X $Y 1504 return 1505} 1506 1507# Allow "scan" bindings 1508if {$::thisPlatform eq "windows"} { 1509 bind [DemoList] <Control-ButtonPress-3> { } 1510} 1511 1512# 1513# List of demos 1514# 1515proc InitDemoList {} { 1516 global DemoCmd 1517 global DemoFile 1518 1519 set t .f1.t 1520 $t element create e1 text -fill [list $::SystemHighlightText {selected focus}] 1521 $t element create e2 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ 1522 -showfocus yes 1523 $t style create s1 1524 $t style elements s1 {e2 e1} 1525 # Tk listbox has linespace + 1 height 1526 $t style layout s1 e2 -union [list e1] -ipadx 2 -ipady {0 1} -iexpand e 1527 1528 $t column configure C0 -itemstyle s1 1529 1530 # "Picture Catalog" DemoPictureCatalog 1531 # "Picture Catalog 2" DemoPictureCatalog2 1532 # "Folder Contents (Vertical)" DemoExplorerFilesV 1533 foreach {label command file} [list \ 1534 "Random $::RandomN Items" DemoRandom random.tcl \ 1535 "Random $::RandomN Items, Button Images" DemoRandom2 random.tcl \ 1536 "Outlook Express (Folders)" DemoOutlookFolders outlook-folders.tcl \ 1537 "Outlook Express (Newsgroup)" DemoOutlookNewsgroup outlook-newgroup.tcl \ 1538 "Explorer (Details, Win98)" DemoExplorerDetails explorer.tcl \ 1539 "Explorer (Details, Win7)" DemoExplorerDetailsWin7 explorer.tcl \ 1540 "Explorer (List)" DemoExplorerList explorer.tcl \ 1541 "Explorer (Large icons, Win98)" DemoExplorerLargeIcons explorer.tcl \ 1542 "Explorer (Large icons, Win7)" DemoExplorerLargeIconsWin7 explorer.tcl \ 1543 "Explorer (Small icons)" DemoExplorerSmallIcons explorer.tcl \ 1544 "Internet Options" DemoInternetOptions www-options.tcl \ 1545 "Help Contents" DemoHelpContents help.tcl \ 1546 "Layout" DemoLayout layout.tcl \ 1547 "MailWasher" DemoMailWasher mailwasher.tcl \ 1548 "Bitmaps" DemoBitmaps bitmaps.tcl \ 1549 "iMovie" DemoIMovie imovie.tcl \ 1550 "iMovie (Wrap)" DemoIMovieWrap imovie.tcl \ 1551 "Firefox Privacy" DemoFirefoxPrivacy firefox.tcl \ 1552 "Textvariable" DemoTextvariable textvariable.tcl \ 1553 "Big List" DemoBigList biglist.tcl \ 1554 "Column Spanning" DemoSpan span.tcl \ 1555 "My Computer" DemoMyComputer mycomputer.tcl \ 1556 "Column Locking" DemoColumnLock column-lock.tcl \ 1557 "Gradients" DemoGradients gradients.tcl \ 1558 "Gradients II" DemoGradients2 gradients2.tcl \ 1559 "Gradients III" DemoGradients3 gradients3.tcl \ 1560 "Headers" DemoHeaders headers.tcl \ 1561 "Table" DemoTable table.tcl \ 1562 ] { 1563 set item [$t item create] 1564 $t item lastchild root $item 1565 # $t item style set $item C0 s1 1566 $t item text $item C0 $label 1567 set DemoCmd($item) $command 1568 set DemoFile($item) $file 1569 } 1570 $t yview moveto 0.0 1571 return 1572} 1573 1574InitDemoList 1575 1576proc TimerStart {} { 1577 if {[info tclversion] < 8.5} { 1578 return [set ::gStartTime [clock clicks -milliseconds]] 1579 } 1580 return [set ::gStartTime [clock microseconds]] 1581} 1582 1583proc TimerStop {{startTime ""}} { 1584 if {[info tclversion] < 8.5} { 1585 set endTime [clock clicks -milliseconds] 1586 if {$startTime eq ""} { set startTime $::gStartTime } 1587 return [format "%.2g" [expr {($endTime - $startTime) / 1000.0}]] 1588 } 1589 set endTime [clock microseconds] 1590 if {$startTime eq ""} { set startTime $::gStartTime } 1591 return [format "%.2g" [expr {($endTime - $startTime) / 1000000.0}]] 1592} 1593 1594proc DemoSet {namespace file} { 1595 DemoClear 1596 TimerStart 1597 uplevel #0 ${namespace}::Init [DemoList] 1598 dbwin "set list in [TimerStop] seconds\n" 1599 [DemoList] xview moveto 0 1600 [DemoList] yview moveto 0 1601 update 1602 DisplayStylesInList 1603 SourceWindow::ShowSource $file 1604 catch { 1605 if {[winfo ismapped .styleEditor]} { 1606 StyleEditor::SetListOfStyles 1607 } 1608 } 1609 AddBindTag [DemoList] TagIdentify 1610 return 1611} 1612 1613.f1.t notify bind .f1.t <Selection> { 1614 if {%c == 1} { 1615 set item [%T selection get 0] 1616 DemoSet $DemoCmd($item) $DemoFile($item) 1617 } 1618} 1619 1620proc DisplayStylesInList {} { 1621 1622 set T [DemoList] 1623 set t .f4.t 1624 1625 # Create elements and styles the first time this is called 1626 if {[llength [$t style names]] == 0} { 1627 $t element create e1 text -fill [list $::SystemHighlightText {selected focus}] 1628 $t element create e2 text -fill [list $::SystemHighlightText {selected focus} "" {selected !focus} blue {}] 1629 $t element create e3 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ 1630 -showfocus yes 1631 1632 $t style create s1 1633 $t style elements s1 {e3 e1} 1634 $t style layout s1 e3 -union [list e1] -ipadx 1 -ipady {0 1} 1635 1636 $t style create s2 1637 $t style elements s2 {e3 e1 e2} 1638 $t style layout s2 e1 -padx {0 4} 1639 $t style layout s2 e3 -union [list e1 e2] -ipadx 1 -ipady {0 1} 1640 } 1641 1642 # Clear the list 1643 $t item delete all 1644 1645 # One item for each element in the demo list 1646 foreach elem [lsort -dictionary [$T element names]] { 1647 set item [$t item create -button yes -open no] 1648 $t item style set $item C0 s1 1649 $t item text $item C0 "Element $elem ([$T element type $elem])" 1650 1651 # One item for each configuration option for this element 1652 foreach list [$T element configure $elem] { 1653 lassign $list name x y default current 1654 set item2 [$t item create] 1655 if {[string equal $default $current]} { 1656 $t item style set $item2 C0 s1 1657 $t item element configure $item2 C0 e1 -text [list $name $current] 1658 } else { 1659 $t item style set $item2 C0 s2 1660 $t item element configure $item2 C0 e1 -text $name + e2 -text [list $current] 1661 } 1662 $t item lastchild $item $item2 1663 } 1664 $t item lastchild root $item 1665 } 1666 1667 # One item for each style in the demo list 1668 foreach style [lsort -dictionary [$T style names]] { 1669 set item [$t item create -button yes -open no] 1670 $t item style set $item C0 s1 1671 $t item text $item C0 "Style $style" 1672 1673 # One item for each element in the style 1674 foreach elem [$T style elements $style] { 1675 set item2 [$t item create -button yes -open no] 1676 $t item style set $item2 C0 s1 1677 $t item text $item2 C0 "Element $elem ([$T element type $elem])" 1678 1679 # One item for each layout option for this element in this style 1680 foreach {option value} [$T style layout $style $elem] { 1681 set item3 [$t item create] 1682 # $t item hasbutton $item3 no 1683 $t item style set $item3 C0 s1 1684 $t item text $item3 C0 [list $option $value] 1685 $t item lastchild $item2 $item3 1686 } 1687 $t item lastchild $item $item2 1688 } 1689 $t item lastchild root $item 1690 } 1691 1692 $t xview moveto 0 1693 $t yview moveto 0 1694 return 1695} 1696 1697proc DisplayStylesInItem {item} { 1698 1699 set T [DemoList] 1700 set t .f3.t 1701 $t column configure C0 -text "Styles in item [$T item id $item]" 1702 1703 # Create elements and styles the first time this is called 1704 if {[llength [$t style names]] == 0} { 1705 $t element create e1 text -fill [list $::SystemHighlightText {selected focus}] 1706 $t element create e2 text -fill [list $::SystemHighlightText {selected focus} "" {selected !focus} blue {}] 1707 $t element create e3 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ 1708 -showfocus yes 1709 1710 $t style create s1 1711 $t style elements s1 {e3 e1} 1712 $t style layout s1 e3 -union [list e1] -ipadx {1 2} -ipady {0 1} 1713 1714 $t style create s2 1715 $t style elements s2 {e3 e1 e2} 1716 $t style layout s2 e1 -padx {0 4} 1717 $t style layout s2 e3 -union [list e1 e2] -ipadx 1 -ipady {0 1} 1718 } 1719 1720 # Clear the list 1721 $t item delete all 1722 1723 # One item for each item-column 1724 foreach style [$T item style set $item] column [$T column list] { 1725 set item2 [$t item create -open no] 1726 $t item style set $item2 C0 s1 1727 if {$style ne ""} { 1728 $t item element configure $item2 C0 e1 \ 1729 -text "Column $column: Style $style" 1730 } else { 1731 $t item element configure $item2 C0 e1 \ 1732 -text "Column $column: no style" 1733 } 1734 1735 # One item for each element in this style 1736 if {[string length $style]} { 1737 set button 0 1738 foreach elem [$T item style elements $item $column] { 1739 set button 1 1740 set item3 [$t item create -button yes -open no] 1741 $t item style set $item3 C0 s1 1742 $t item element configure $item3 C0 e1 \ 1743 -text "Element $elem ([$T element type $elem])" 1744 1745 # One item for each configuration option in this element 1746 foreach list [$T item element configure $item $column $elem] { 1747 lassign $list name x y default current 1748 set item4 [$t item create] 1749 set masterDefault [$T element cget $elem $name] 1750 set sameAsMaster [string equal $masterDefault $current] 1751 if {!$sameAsMaster && ![string length $current]} { 1752 set sameAsMaster 1 1753 set current $masterDefault 1754 } 1755 1756 if {$sameAsMaster} { 1757 $t item style set $item4 C0 s1 1758 $t item element configure $item4 C0 e1 -text "$name [list $current]" 1759 } else { 1760 $t item style set $item4 C0 s2 1761 $t item element configure $item4 C0 e1 -text $name + e2 -text [list $current] 1762 } 1763 $t item lastchild $item3 $item4 1764 } 1765 $t item lastchild $item2 $item3 1766 } 1767 if {$button} { 1768 $t item configure $item2 -button yes 1769 } 1770 } 1771 $t item lastchild root $item2 1772 } 1773 $t xview moveto 0 1774 $t yview moveto 0 1775 1776 return 1777} 1778 1779# When one item is selected in the demo list, display the styles in that item. 1780# See DemoClear for why the tag "DontDelete" is used. 1781set DisplayStylesInItem(item) "" 1782set MouseIsDown 0 1783bind [DemoList] <ButtonPress-1> { 1784 set MouseIsDown 1 1785} 1786bind [DemoList] <ButtonRelease-1> { 1787 set MouseIsDown 0 1788 if {$DisplayStylesInItem(item) ne ""} { 1789 DisplayStylesInItem $DisplayStylesInItem(item) 1790 set DisplayStylesInItem(item) "" 1791 } 1792} 1793[DemoList] notify bind DontDelete <Selection> { 1794 if {%c == 1} { 1795 if {$MouseIsDown} { 1796 set DisplayStylesInItem(item) [%T selection get 0] 1797 } else { 1798 DisplayStylesInItem [%T selection get 0] 1799 } 1800 } 1801} 1802 1803# Move columns when ColumnDrag-receive is generated. 1804# See DemoClear for why the tag "DontDelete" is used. 1805[DemoList] notify bind DontDelete <ColumnDrag-receive> { 1806 %T column move %C %b 1807} 1808 1809proc DemoClear {} { 1810 1811 set T [DemoList] 1812 1813 # Delete all the items (except the root item, it never gets deleted). 1814 $T item delete all 1815 1816 # Delete all the headers (except the first header, it never gets deleted). 1817 $T header delete all 1818 1819 # Clear all bindings on the demo list added by the previous demo. 1820 # The bindings are removed from the tag $T only. For those 1821 # bindings that should not be deleted we use the tag DontDelete. 1822 # DontDelete is not a special name it just needs to be different 1823 # than $T. 1824 $T notify unbind $T 1825 1826 # Clear all run-time states 1827 eval $T header state undefine [$T header state names] 1828 eval $T item state undefine [$T item state names] 1829 1830 # Clear the styles-in-item list 1831 .f3.t item delete all 1832 1833 # Delete columns in demo list 1834 $T column delete all 1835 1836 # Delete all styles in demo list 1837 eval $T style delete [$T style names] 1838 1839 # Delete all elements in demo list 1840 eval $T element delete [$T element names] 1841 1842 # Delete -window windows 1843 foreach child [winfo children $T] { 1844 if {[string equal $child $T.mTree] || [string equal $child $T.mColumn]} continue 1845 destroy $child 1846 } 1847 1848 # Restore defaults to marquee 1849 $T marquee configure -fill {} -outline {} -outlinewidth 1 1850 1851 # Delete gradients 1852 eval $T gradient delete [$T gradient names] 1853 1854 $T item configure root -button no -wrap no 1855 $T item expand root 1856 1857 # Restore header defaults 1858 foreach spec [$T header configure 0] { 1859 if {[llength $spec] == 2} continue 1860 lassign $spec name x y default current 1861 $T header configure all $name $default 1862 } 1863 1864 # Restore some happy defaults to the demo list 1865 foreach spec [$T configure] { 1866 if {[llength $spec] == 2} continue 1867 lassign $spec name x y default current 1868 $T configure $name $default 1869 } 1870 $T configure -background white 1871 $T configure -borderwidth [expr {$::tileFull ? 0 : 6}] 1872 $T configure -font DemoFont 1873 if {[Platform unix]} { 1874 $T configure -headerfont DemoFont 1875 } 1876 $T configure -highlightthickness [expr {$::tileFull ? 0 : 3}] 1877 $T configure -relief ridge 1878 1879 switch -- [$T theme platform] { 1880 visualstyles { 1881 $T theme setwindowtheme "" 1882 } 1883 } 1884 1885 # Restore defaults to the tail column 1886 foreach spec [$T column configure tail] { 1887 if {[llength $spec] == 2} continue 1888 lassign $spec name x y default current 1889 $T column configure tail $name $default 1890 } 1891 1892 # Enable drag-and-drop column reordering. This also requires the 1893 # <ColumnDrag> event be installed. 1894 $T header dragconfigure -enable yes 1895 $T header dragconfigure all -enable yes -draw yes 1896 1897 # Re-active the column drag-and-drop binding in case the previous demo 1898 # deactivated it. 1899 $T notify configure DontDelete <ColumnDrag-receive> -active yes 1900 1901 # Restore default bindings to the demo list 1902 bindtags $T [list $T TreeCtrl [winfo toplevel $T] all DisplayStylesInItemBindTag] 1903 1904 catch {destroy $T.entry} 1905 catch {destroy $T.text} 1906 1907 return 1908} 1909 1910# 1911# Demo: Picture catalog 1912# 1913proc DemoPictureCatalog {} { 1914 1915 set T [DemoList] 1916 1917 $T configure -showroot no -showbuttons no -showlines no \ 1918 -selectmode multiple -orient horizontal -wrap window \ 1919 -yscrollincrement 50 -showheader no 1920 1921 $T column create 1922 1923 $T element create elemTxt text -fill {SystemHighlightText {selected focus}} 1924 $T element create elemSelTxt rect -fill {SystemHighlight {selected focus}} 1925 $T element create elemSelImg rect -outline {SystemHighlight {selected focus}} \ 1926 -outlinewidth 4 1927 $T element create elemImg rect -fill gray -width 80 -height 120 1928 1929 set S [$T style create STYLE -orient vertical] 1930 $T style elements $S {elemSelImg elemImg elemSelTxt elemTxt} 1931 $T style layout $S elemSelImg -union elemImg -ipadx 6 -ipady 6 1932 $T style layout $S elemSelTxt -union elemTxt 1933 $T style layout $S elemImg -pady {0 6} 1934 1935 for {set i 1} {$i <= 10} {incr i} { 1936 set I [$T item create] 1937 $T item style set $I 0 $S 1938 $T item text $I 0 "Picture #$i" 1939 $T item lastchild root $I 1940 } 1941 1942 return 1943} 1944 1945# 1946# Demo: Picture catalog 1947# 1948proc DemoPictureCatalog2 {} { 1949 1950 set T [DemoList] 1951 1952 $T configure -showroot no -showbuttons no -showlines no \ 1953 -selectmode multiple -orient horizontal -wrap window \ 1954 -yscrollincrement 50 -showheader no 1955 1956 $T column create 1957 1958 $T element create elemTxt text -fill {SystemHighlightText {selected focus}} \ 1959 -justify left -wrap word -lines 3 1960 $T element create elemSelTxt rect -fill {SystemHighlight {selected focus}} 1961 $T element create elemSelImg rect -outline {SystemHighlight {selected focus}} \ 1962 -outlinewidth 4 1963 $T element create elemImg rect -fill gray 1964 1965 set S [$T style create STYLE -orient vertical] 1966 $T style elements $S {elemSelImg elemImg elemSelTxt elemTxt} 1967 $T style layout $S elemSelImg -union elemImg \ 1968 -ipadx 6 -ipady 6 1969 $T style layout $S elemSelTxt -union elemTxt 1970 $T style layout $S elemImg -pady {0 6} 1971 $T style layout $S elemImg -expand n 1972 $T style layout $S elemTxt -expand s 1973 1974 for {set i 1} {$i <= 10} {incr i} { 1975 set I [$T item create] 1976 $T item style set $I 0 $S 1977 $T item text $I 0 "This is\nPicture\n#$i" 1978 $T item element configure $I 0 elemImg -width [expr int(20 + rand() * 80)] \ 1979 -height [expr int(20 + rand() * 120)] 1980 $T item lastchild root $I 1981 } 1982 1983 return 1984} 1985 1986 1987 1988 1989proc CursorWindow {} { 1990 set w .cursors 1991 if {[winfo exists $w]} { 1992 destroy $w 1993 } 1994 toplevel $w 1995 set c [canvas $w.canvas -background white -width [expr {50 * 10}] \ 1996 -highlightthickness 0 -borderwidth 0] 1997 pack $c -expand yes -fill both 1998 set cursors { 1999 X_cursor 2000 arrow 2001 based_arrow_down 2002 based_arrow_up 2003 boat 2004 bogosity 2005 bottom_left_corner 2006 bottom_right_corner 2007 bottom_side 2008 bottom_tee 2009 box_spiral 2010 center_ptr 2011 circle 2012 clock 2013 coffee_mug 2014 cross 2015 cross_reverse 2016 crosshair 2017 diamond_cross 2018 dot 2019 dotbox 2020 double_arrow 2021 draft_large 2022 draft_small 2023 draped_box 2024 exchange 2025 fleur 2026 gobbler 2027 gumby 2028 hand1 2029 hand2 2030 heart 2031 icon 2032 iron_cross 2033 left_ptr 2034 left_side 2035 left_tee 2036 leftbutton 2037 ll_angle 2038 lr_angle 2039 man 2040 middlebutton 2041 mouse 2042 pencil 2043 pirate 2044 plus 2045 question_arrow 2046 right_ptr 2047 right_side 2048 right_tee 2049 rightbutton 2050 rtl_logo 2051 sailboat 2052 sb_down_arrow 2053 sb_h_double_arrow 2054 sb_left_arrow 2055 sb_right_arrow 2056 sb_up_arrow 2057 sb_v_double_arrow 2058 shuttle 2059 sizing 2060 spider 2061 spraycan 2062 star 2063 target 2064 tcross 2065 top_left_arrow 2066 top_left_corner 2067 top_right_corner 2068 top_side 2069 top_tee 2070 trek 2071 ul_angle 2072 umbrella 2073 ur_angle 2074 watch 2075 xterm 2076 } 2077 set col 0 2078 set row 0 2079 foreach cursor $cursors { 2080 set x [expr {$col * 50}] 2081 set y [expr {$row * 40}] 2082 $c create rectangle $x $y [expr {$x + 50}] [expr {$y + 40}] \ 2083 -fill gray90 -outline black -width 2 -tags $cursor.rect 2084 $c create text [expr {$x + 50 / 2}] [expr {$y + 4}] -text $cursor \ 2085 -anchor n -width 42 -tags $cursor.text 2086 if {[incr col] == 10} { 2087 set col 0 2088 incr row 2089 } 2090 $c bind $cursor.rect <Enter> " 2091 $c configure -cursor $cursor 2092 $c itemconfigure $cursor.rect -fill linen 2093 " 2094 $c bind $cursor.rect <Leave> " 2095 $c configure -cursor {} 2096 $c itemconfigure $cursor.rect -fill gray90 2097 " 2098 $c bind $cursor.text <Enter> " 2099 $c configure -cursor $cursor 2100 " 2101 $c bind $cursor.text <Leave> " 2102 $c configure -cursor {} 2103 " 2104 } 2105 $c configure -height [expr {($row + 1) * 40}] 2106 return 2107} 2108 2109# A little screen magnifier 2110if {[llength [info commands loupe]]} { 2111 2112 namespace eval LoupeWindow { 2113 variable Priv 2114 set Priv(zoom) 2 2115 set Priv(x) 0 2116 set Priv(y) 0 2117 set Priv(auto) 1 2118 set Priv(afterId) "" 2119 set Priv(image) ::LoupeWindow::Image 2120 set Priv(delay) 500 2121 } 2122 2123 proc LoupeWindow::After {} { 2124 variable Priv 2125 set x [winfo pointerx .] 2126 set y [winfo pointery .] 2127 if {$Priv(auto) || ($Priv(x) != $x) || ($Priv(y) != $y)} { 2128 set w [image width $Priv(image)] 2129 set h [image height $Priv(image)] 2130 loupe $Priv(image) $x $y $w $h $Priv(zoom) 2131 set Priv(x) $x 2132 set Priv(y) $y 2133 } 2134 set Priv(afterId) [after $Priv(delay) LoupeWindow::After] 2135 return 2136 } 2137 2138 proc LoupeWindow::Init {} { 2139 variable Priv 2140 set w [toplevel .loupe] 2141 wm title $w "TreeCtrl Magnifier" 2142 wm withdraw $w 2143 if {[Platform macintosh macosx]} { 2144 wm geometry $w +6+30 2145 } else { 2146 wm geometry $w -0+0 2147 } 2148 image create photo $Priv(image) -width 280 -height 150 2149 pack [label $w.label -image $Priv(image) -borderwidth 1 -relief sunken] \ 2150 -expand yes -fill both 2151 2152 set f [frame $w.zoom -borderwidth 0] 2153 radiobutton $f.r1 -text "1x" -variable ::LoupeWindow::Priv(zoom) -value 1 2154 radiobutton $f.r2 -text "2x" -variable ::LoupeWindow::Priv(zoom) -value 2 2155 radiobutton $f.r4 -text "4x" -variable ::LoupeWindow::Priv(zoom) -value 4 2156 radiobutton $f.r8 -text "8x" -variable ::LoupeWindow::Priv(zoom) -value 8 2157 pack $f.r1 $f.r2 $f.r4 $f.r8 -side left 2158 pack $f -side bottom -anchor center 2159 2160 # Resize the image with the window 2161 bind LoupeWindow <Configure> { 2162 LoupeWindow::ResizeImage %w %h 2163 } 2164 bindtags $w.label [concat [bindtags .loupe] LoupeWindow] 2165 2166 wm protocol $w WM_DELETE_WINDOW "LoupeWindow::ToggleWindowVisibility" 2167 return 2168 } 2169 2170 proc LoupeWindow::ResizeImage {w h} { 2171 variable Priv 2172 set w [expr {$w - 2}] 2173 set h [expr {$h - 2}] 2174 if {$w != [$Priv(image) cget -width] || 2175 $h != [$Priv(image) cget -height]} { 2176 $Priv(image) configure -width $w -height $h 2177 loupe $Priv(image) $Priv(x) $Priv(y) $w $h $Priv(zoom) 2178 } 2179 return 2180 } 2181 2182 proc LoupeWindow::ToggleWindowVisibility {} { 2183 variable Priv 2184 set w .loupe 2185 if {![winfo exists $w]} { 2186 LoupeWindow::Init 2187 } 2188 if {[winfo ismapped $w]} { 2189 after cancel $Priv(afterId) 2190 wm withdraw $w 2191 } else { 2192 After 2193 wm deiconify $w 2194 raise $w 2195 } 2196 return 2197 } 2198} 2199 2200proc RandomPerfTest {} { 2201 set ::RandomN 15000 2202 DemoSet DemoRandom random.tcl 2203 [DemoList] item expand all 2204 [DemoList] style layout styFolder elemTxtName -squeeze x 2205 [DemoList] style layout styFile elemTxtName -squeeze x 2206 [DemoList] elem conf elemTxtName -lines 1 2207 update 2208 puts [time {[DemoList] colu conf 0 -width 160 ; update}] 2209 return 2210} 2211 2212
