[Richard Suchenwirth] 2006-01-30 - The following script is a radical rewrite for use with [Sepp] and [eTcl], of regbrowser.tcl (author unknown), that comes with the Keuchel distribution of Tcl 8.4a2 on [PocketPC]. It allows to wander through the tree of registry keys, and list the items there. The script seems to have been originated on the early landscape-screen "clamshell" pocket PCs. I also used [Tk]'s [panedwindow] and [labelframe] instead of the [BWidget] equivalents. One nice feature is that one can toggle the orientation of the panedwindow form horizontal to vertical and back, depending what fits better for the small screen. [http://mini.net/files/registrar.jpg] ---- package require registry package require BWidget 1.3 namespace eval regb { variable BaseKeys { HKEY_CLASSES_ROOT HKEY_LOCAL_MACHINE HKEY_CURRENT_USER } variable PROGINC -1 variable PROGTXT "" } proc regb::build_screen {w} { variable BaseKeys if {$w ne ""} {toplevel $w} NoteBook $w.nb -internalborderwidth 0 foreach k $BaseKeys { build_tree_tab $w.nb $k } build_info_tab $w.nb $w.nb compute_size pack $w.nb -fill both -expand yes $w.nb raise [$w.nb pages end] if {$w eq ""} {set w .; wm deic $w} wm title $w Registrar wm geometry $w 240x268 catch {wce siphide} } proc regb::build_info_tab {nb} { set f [$nb insert end help -text ?] text $f.t $f.t tag config HEAD -font {Tahoma 9 bold} pack $f.t $f.t insert end "\nSimple Registry Browser" HEAD $f.t insert end "\n Each Tab is a separate HKEY section of Registry Selecting a key on the left side shows all values under that key\n\n" $f.t insert end "Mouse Actions:\n" HEAD $f.t insert end "Click : Selects that key Click: (on Cross) Opens/closes folder\n\n" $f.t insert end "Arrow Key Actions:\n" HEAD $f.t insert end "Up : Moves selection to previous key Down : Moves selection to next key Right : Opens key folder (subkeys) Left : Closes key folder (subkeys)" } proc regb::make_readable key { set str {} foreach word [lrange [split $key _] 1 end] { regexp {(.)(.*)} $word -> l rest lappend str "$l[string tolower $rest]" } join $str } proc regb::build_tree_tab {nb key} { set font {Tahoma 8} set f [$nb insert end $key -text [make_readable $key]] set pw [panedwindow $f.pw -ori vert] bind $pw {toggle'ori %W} set tf [labelframe $pw.tf -text $key -font $font] $pw add $tf set sw [ScrolledWindow $tf.sw -relief sunken -borderwidth 0] set tree [Tree $sw.tree -deltax 8 \ -opencmd "regb::change_node 1 $sw.tree" \ -closecmd "regb::change_node 0 $sw.tree"] $sw setwidget $tree pack $sw -fill both -expand yes set sw [ScrolledWindow $pw.sw -borderwidth 0] $pw add $sw set txt [text $sw.txt -font $font] $txt tag config MAINKEY -font "$font bold" $sw setwidget $txt pack $pw -fill both -expand yes after idle "$pw sash place 0 0 140" $tree configure -selectcommand "regb::update_contents $txt" $nb itemconfigure $key \ -createcmd "regb::init_tree $tree $key" \ -raisecmd "focus $tree" return $tree } proc toggle'ori w { $w config -ori [expr {[$w cget -ori] eq "horizontal"? "vertical" : "horizontal"}] } proc regb::init_tree {tw key} { variable PROGTXT "Creating Tree for \n $key" variable PROGINC -1 ProgressDlg .prg -textvariable ::regb::PROGTXT -variable ::regb::PROGINC \ -type infinite -maximum 50000 $tw configure -redraw 0 add_nodes $tw root $key 0 $tw configure -redraw 1 update destroy .prg } proc max args { if {[llength $args] == 1} { set args [lindex $args 0] } lindex [lsort -dict -dec $args] 0 } set regb::NODECOUNT 0 proc regb::add_nodes {tw node key {cfg 1}} { variable PROGINC if [catch {registry keys $key} keys] { tk_messageBox -icon error -title "Registry Lookup Failed" -message \ "Unable to get keys from registry.\nKey: $key\nError: $keys" } else { set cursor [$tw cget -cursor] $tw configure -cursor watch foreach k $keys { $tw insert end $node nd:[incr ::regb::NODECOUNT] \ -text $k \ -data "$key\\$k" \ -drawcross allways \ -image [Bitmap::get folder] incr PROGINC } $tw configure -cursor $cursor } set data "$key\n\n" if [catch {registry values $key} vals] { tk_messageBox -icon error -title "Registry Lookup Failed" -message \ "Unable to get values from registry.\nKey: $key\nError: $vals" append data "ERROR: Cannot Get Values" } else { set items {} foreach n $vals { set t [registry type $key $n] set v [registry get $key $n] if {$t eq "binary"} {set v [hexdump $v]} lappend items [format "%s (%s) %s" $n $t $v ] } if {[llength $items]} { append data [join $items "\n"] } else {append data "(no values)"} } if { $cfg } { $tw itemconfigure $node -drawcross auto -data $data } incr PROGINC } proc regb::update_contents {txt tw node} { $txt config -state normal $txt delete 1.0 end set dat [$tw itemcget $node -data] if {[$tw itemcget $node -drawcross] eq "allways"} { add_nodes $tw $node $dat set dat [$tw itemcget $node -data] } $txt insert end $dat $txt tag add MAINKEY 1.0 2.0 $txt config -state disabled } proc regb::change_node {open tw node} { if {$open} { if {[$tw itemcget $node -drawcross] eq "allways"} { add_nodes $tw $node [$tw itemcget $node -data] if {[llength [$tw nodes $node]]} { $tw itemconfigure $node -image [Bitmap::get openfold] } else { $tw itemconfigure $node -image [Bitmap::get folder] } } else { $tw itemconfigure $node -image [Bitmap::get openfold] } } else { $tw itemconfigure $node -image [Bitmap::get folder] } } #-- toplevel entry function proc registrar {{w ""}} {regb::build_screen $w}