package require starkit
starkit::startup
package require Tk
# Uncomment the next two lines if you want the tile package.
# package require tile
# namespace import -force ::tile::*
# Create the window
proc DriveTool {} {
puts "--proc DriveTool-------------------"
set ::quickFile [file dir .]/$::tcl_platform(user).drv
. configure -borderwidth 1
wm protocol . WM_DELETE_WINDOW {exit}
wm title . "Windows Drives Disconnect/Reconnect Tool"
wm resizable . 1 0
button .quickSave -text "Quick Save/Disconnect" -command {QuickSave}
button .quickLoad -text "Quick Load/Restore" -command {QuickLoad}
button .load -text "Load Drives From File" -command {LoadFile}
button .disconnect -text "Disconnect Current Drives" -command {Disconnect}
button .showConsole -text "Console Show" -command {console show}
button .save -text "Save Current Drives To File" -command {SaveFile}
button .cancel -text Exit -command {exit}
grid .quickSave - - -sticky news
grid .quickLoad - - -sticky news
grid .load - - -sticky news
grid .disconnect - - -sticky news
grid .showConsole - - -sticky news
grid .save - - -sticky news
grid .cancel - - -sticky news
grid rowconfigure . 0 -weight 1
grid columnconfigure . 1 -weight 1
raise .
grab set .
}
# Disconnect All network drives.
proc Disconnect { } {
puts "--proc Disconnect------------------"
foreach drive [string map {/ ""} [file volumes]] {
if { [catch {
exec net use /delete $drive
puts "$drive disconnected."
} errorString] } {
puts "Disconnect: $drive: $errorString"
}
}
.quickSave configure -state disabled
.disconnect configure -state disabled
.save configure -state disabled
.quickLoad configure -state enabled
}
# Parses drives into Tcl list from Windows Net Program
proc ParseDrives { } {
puts "--proc Parse Drives----------------"
foreach drive [string map {/ ""} [file volumes]] {
if { [catch {
set data [split [exec net use $drive] \n]
foreach line $data {
if { [regexp {^Remote name +(.*)} $line -> path]} {
set volume $drive
lappend volume $path
lappend paths $volume
}
}
} errorString] } {
puts "SaveFile: $errorString"
}
}
if { [info exists paths] } {
return $paths
} else {
return ""
}
}
# Saves file and disconnect drives to default location without Save Dialog.
proc QuickSave { } {
puts "--proc QuickSave---------------"
set paths [ParseDrives]
set fileid [open $::quickFile w]
puts $fileid $paths
close $fileid
puts "File saved: $::quickFile"
Disconnect
}
# Mounts drive from Quick Save file
proc QuickLoad { } {
puts "--proc QuickLoad-------------------"
if { [catch {
set fileid [open $::quickFile r]
set paths [read $fileid]
close $fileid
puts "File opened: $::quickFile"
MountDrives $paths
.quickSave configure -state enabled
.save configure -state enabled
.quickLoad configure -state disabled
} errorString] } {
puts "QuickLoad: $errorString"
}
}
# Save the data field.
proc SaveFile { } {
puts "--proc SaveFile--------------------"
set types {
{"Drive Files" {.drv} }
}
set file [tk_getSaveFile -filetypes $types -defaultextension .drv]
# Only save the file if the user click save not cancel
if {! [string match "" $file ]} {
set paths [ParseDrives]
set fileid [open $file w]
puts $fileid $paths
close $fileid
puts "File saved: $file"
} else {
puts "File Not Saved."
}
}
# Mount Drives
proc MountDrives {paths} {
puts "--proc MountDrives-----------------"
foreach line $paths {
set drive [lindex $line 0]
set path [lindex $line 1]
if { [catch {
exec net use $drive $path
} errorString] } {
puts "MountDrives: $errorString"
}
}
.disconnect configure -state enabled
}
# Load the File and Mount Drives
proc LoadFile {} {
puts "--proc LoadFile--------------------"
set types {
{"Drive Files" {.drv} }
}
set file [tk_getOpenFile -filetypes $types -defaultextension .drv]
if { $file == ""} {return}
set fileid [open $file r]
set paths [read $fileid]
close $fileid
MountDrives $paths
}
# show background errors
proc bgerror {value} {puts $value}
# Call the main window
DriveToolpcam Nice and useful tool, that I shall be using often, thanks. One thing though I would remove the line calling for tile (and the category, sorry Larry) as it is not needed I think.LV At first I misunderstood your comment. After starting to reply several times, I figured out that your meaning was probably Tile is the old name of the new widget set - you should be referencing ttk instead..pcam In fact, I meant, that this code despite loading the tile package, and using the tile namespace does in fact not need any Tile feature. I tried it without and it runs perfectly. All that for the purpose of running on older versions. Well I leave the code as is, that was just a comment. Also this means this is possibly not the best example of using tile either (maybe the category using tile is not appropriate). BTW thanks for adding these categories, as they become more useful as the wiki grows.LV Okay - I hadn't tried to run the program yet, so I didn't know that it didn't actually USE tile. You are right - if a program doesn't make use of the package, then not mentioning it might allow it to run on older versions of Tk. Perhaps the developer did it this way so that, in the future, if someone included one of the widgets in use in Ttk, it would be used by his program automatically.
JOB - 2018-03-14Found out that the ParseDrives procedure does not return any result (under Windows 7). So here is a modified version purely based on string comparison:
# parses available volumens and tries to detect mounted volumen names
# based on the windows "net" command
# return value is a list containing {drive-letter remote-name} list items
#
proc ParseDrives { } {
set remote_list [list]
foreach drive [file volumes] {
set drive [string map {"/" ""} $drive]
if {[string toupper $drive] == "C:"} { continue }
if { [catch {set data [split [exec net use $drive] "\n"]} errmsg] } {
# nothing more to do...
# puts $errmsg
} else {
foreach line $data {
if { [string first "remote" [string tolower $line]] != -1 } {
set remotename [string trim [lindex [split $line " "] end]]
lappend remote_list [list $drive $remotename]
break
}
}
}
}
return $remote_list
}