Can Tcl manage Windows "shell links"? Certainly; there are at least seven ways:
dde execute progman progman "" "\[CreateGroup(Bogus)\]"
dde execute progman progman "" \
"\[AddItem(notepad.exe,BogusPadLink)\]"
dde execute progman progman "" "\[ShowGroup(Bogus,0)\]"
dde execute progman progman "" "\[ShowGroup(Bogus,1)\]"
dde execute progman progman "" "\[DeleteItem(BogusPadLink)\]"
dde execute progman progman "" "\[DeleteGroup(Bogus)\]"A ZIP file containing a PDF with detailed information on the link file format [L5 ]
Anybody knows of an extension that lets you create unicode-aware shell links ? For example, for chinese version of windows (none of the above seems to work for me)
RS tried reading such links, or "shortcuts", in a simpler, and pure-Tcl way. If you look at .lnk files in hexdump, you notice that they contain the string of what they link to, among other things. So I tried just to split on NUL bytes and see whether a snippet is a valid absolute path:
proc readlnk {lnk} {
set res ""
set fp [open $lnk]
foreach snip [split [read $fp] \x00] {
if {[regexp {[A-Z]:\\} $snip] && [file exists $snip]} {
lappend res $snip
}
}
close $fp
join $res
}This is highly experimental, but it worked on the few examples I tried - please correct me if you know better! Simple links to directories and files work. Links that contain an executable invocation with arguments and icon, are a funny mix of ASCII and Unicode, so splitting on 0 is not a good idea there, and the above code does not work.
See also Symbolic links in Windows/CE
package require tcom
set sh [::tcom::ref createobject "WScript.Shell"]
set lnk [$sh CreateShortcut {D:\WORK\Acrobat.lnk}]
$lnk TargetPath {"D:\Program Files\Adobe\Acrobat 4.0\Acrobat\Acrobat.exe"}
$lnk WorkingDirectory {D:\WORK}
$lnk Arguments Tutorial.pdf
$lnk SaveBEO Using Tcom these procedures can create, modify, and get the contents of MS Shortcut files.
package require tcom
#
# Create a new MS Windows shortcut file.
#
# Requires MS Windows 2000 or later (shell v5.00+)
#
# Args: file = Name of shortcut file to create.
# other args are:
# Arguments "args.." = any cmd lines options
# Description "text" = Description of Shortcut
# Hotkey "sequence" = Hot key sequence. Must start with CTRL+ALT. Ex. CTRL+ALT+SHIFT+X
# IconLocation "filename,number" = Path to icon file and icon #
# TargetPath filename = Destination of the shortcut
# WindowStyle style = number (1=normal, 3=maximized, 7=minimized)
# WorkingDirectory dirname = pathname of working directory
# Returns: Boolean result
#
# Example: create_shortcut wish.lnk Description "Tcl/Tk" WindowStyle 1 \
# TargetPath {C:\Program Files\TCL\bin\wish.exe}
#
proc create_shortcut {file args} {
if {![string match ".lnk" [string tolower [file extension $file]]]} {
append file ".lnk"
}
if {[string match "windows" $::tcl_platform(platform)]} {
# Make sure filenames are in nativename format.
array set opts $args
foreach item [list IconLocation Path WorkingDirectory] {
if {[info exists opts($item)]} {
set opts($item) [file nativename $opts($item)]
}
}
set oShell [tcom::ref createobject "WScript.Shell"]
set oShellLink [$oShell CreateShortcut [file nativename $file]]
foreach {opt val} [array get opts] {
if {[catch {$oShellLink $opt $val} result]} {
return -code error "Invalid shortcut option $opt or value $value: $result"
}
}
$oShellLink Save
return 1
}
return 0
}
#
# Modify a MS Windows shortcut file.
#
# Requires MS Windows 2000 or later (shell v5.00+)
#
# Args: file = Shortcut filename.
# other args are:
# Arguments = any cmd lines options
# Description = Description of Shortcut
# Hotkey = Hot key sequence. Must start with CTRL+ALT. Ex. CTRL+ALT+SHIFT+X
# IconLocation = "pathname","icon #"
# Path = destination of the shortcut
# WindowStyle = number (1=normal, 3=maximized, 7=minimized)
# WorkingDirectory = pathname of working directory
# Returns: Boolean result
#
# See: http://www.microsoft.com/technet/scriptcenter/resources/qanda/feb05/hey0209.mspx
# http://www.microsoft.com/technet/scriptcenter/guide/sas_wsh_aytf.mspx
# http://www.microsoft.com/technet/scriptcenter/resources/qanda/aug05/hey0812.mspx
#
proc modify_shortcut {file args} {
set dir [file nativename [file dirname $file]]
set tail [file nativename [file tail $file]]
if {![string match ".lnk" [string tolower [file extension $file]]]} {
return -code error "$file is not a valid shortcut name"
}
if {[string match "windows" $::tcl_platform(platform)]} {
# Make sure filenames are in nativename format.
array set opts $args
foreach item [list IconLocation Path WorkingDirectory] {
if {[info exists opts($item)]} {
set opts($item) [file nativename $opts($item)]
}
}
# Get Shortcut file as an object
set oShell [tcom::ref createobject "Shell.Application"]
set oFolder [$oShell NameSpace $dir]
set oFolderItem [$oFolder ParseName $tail]
# If its a shortcut, do modify
if {[$oFolderItem IsLink]} {
set oShellLink [$oFolderItem GetLink]
foreach {opt val} [array get opts] {
if {[catch {$oShellLink $opt $val} result]} {
return -code error "Invalid shortcut option $opt or value $value: $rsult"
}
}
$oShellLink Save
}
return 1
}
return 0
}
#
# Get linked to file for MS Windows shortcut or file link.
#
# Requires MS Windows 2000 or later (shell v5.00+)
#
# Args: file = Shortcut filename.
# Returns: filename shortcut links to.
#
proc get_shortcut_filename {file} {
set dir [file nativename [file dirname $file]]
set tail [file nativename [file tail $file]]
if {![string match ".lnk" [string tolower [file extension $file]]]} {
return -code error "$file is not a valid shortcut name"
}
if {[string match "windows" $::tcl_platform(platform)]} {
# Get Shortcut file as an object
set oShell [tcom::ref createobject "Shell.Application"]
set oFolder [$oShell NameSpace $dir]
set oFolderItem [$oFolder ParseName $tail]
# If its a shortcut, do modify
if {[$oFolderItem IsLink]} {
set oShellLink [$oFolderItem GetLink]
return [$oShellLink Path]
} else {
if {![catch {file readlink $file} new]} {
set new
} else {
set file
}
}
} else {
if {![catch {file readlink $file} new]} {
set new
} else {
set file
}
}
}
#
# Get properties of a MS Windows shortcut file.
#
# Requires MS Windows 2000 or later (shell v5.00+)
#
# Args: file = Shortcut filename.
# Returns: list of option and value pairs.
#
# Return Example: Path {C:\Program Files\TCL\bin\test.file} Hotkey 0
# Description {Shortcut to test.file} WorkingDirectory {}
# Arguments {} ShowCommand 1 Target ::tcom::handle0x00C2D938
#
proc get_shortcut {file} {
set dir [file nativename [file dirname $file]]
set tail [file nativename [file tail $file]]
if {![string match ".lnk" [string tolower [file extension $file]]]} {
return -code error "$file is not a valid shortcut name"
}
if {[string match "windows" $::tcl_platform(platform)]} {
# Get Shortcut file as an object
set oShell [tcom::ref createobject "Shell.Application"]
set oFolder [$oShell NameSpace $dir]
set oFolderItem [$oFolder ParseName $tail]
# If its a shortcut, get linked to file
if {[$oFolderItem IsLink]} {
set oShellLink [$oFolderItem GetLink]
set if [tcom::info interface $oShellLink]
set list [list]
foreach entry [$if properties] {
foreach {ptr io type name} $entry break
if {[catch {lappend list $name [$oShellLink $name]}]} {
lappend list $name {}
}
}
set list
}
}
}AF - here is a code snippet i wrote to parse .lnk files. i lost interest when i found out how complex the format was and that i would never be able to write them.
array set sizeof [list a 1 A 1 b 1 B 1 h 1 H 1 c 1 s 2 S 2 i 4 I 4 w 8 W 8]
proc getdword {fh} {
binary scan [read $fh 4] i tmp
return $tmp
}
proc getword {fh} {
binary scan [read $fh 2] s tmp
return $tmp
}
proc struct {name defs} {
global struct_sizes struct_defs
set offset 0
set tmp {}
foreach {type n} $defs {
set type [string trim $type]
set n [string trim $n]
if {[string match string* $type]} {
set len [lindex [split $type {[]}] 1]
set type string
} else {
if {![info exists struct_sizes($type)]} { error "unknown type" }
set len $struct_sizes($type)
}
lappend tmp [list $n $offset $type $len]
incr offset $len
}
set struct_defs($name) [linsert $tmp 0 $offset]
}
proc _islnk {fh} {
fconfigure $fh -encoding binary -translation binary -eofchar {}
if {[getdword $fh] != "76"} { close $fh; return -code error "not a lnk file" }
binary scan [read $fh 16] h32 tmp
if {$tmp != "10412000000000000c00000000000064"} { close $fh; return -code error "unrecognized GUID" }
return $fh
}
proc readlnk {lnk} {
array set array {}
set fh [_islnk [open $lnk r]]
set array(flags) [getdword $fh]
set attributes [read $fh 4]
struct $fh * array(created) w array(modified) w array(acessed) w array(size) i array(icon) i array(showwnd) i array(hotkey) i res1 i res2 i
if {$array(flags) & 1 > 0} {
set len [getword $fh]
set w1 [walkStart $fh s *]
while {![walkDone $w1]} {
puts [walkNext $w1]
}
walkEnd $w1
}
set offset [tell $fh]
set structlen [getdword $fh]
if {$array(flags) & 2 > 0 && $structlen > 0} {
struct $fh * nextstruct i flflags i lvt i lvbp i nvt i path i
set nextstruct [expr {[tell $fh] + $structlen - $nextstruct}]
if {($flflags & 1) > 0} {
seek $fh [expr {$offset + $lvt}] start
struct $fh [expr {[getdword $fh] - 4}] type i serial i noff i name a*
seek $fh [expr {$offset + $lvbp}] start
set base [read $fh [expr {$offset + $structlen - [tell $fh]}]]
}
if {($flflags & 2) > 0} {
seek $fh [expr {$offset + $nvt}] start
struct $fh [expr {[getdword $fh] - 4}] a i b i c i d i base a*
}
seek $fh [expr {$offset + $path}] start
set path [read $fh [expr {$nextstruct - [tell $fh]}]]
seek $fh $nextstruct start
}
set array(base) [string trimright $base \x00]
set array(final) [string trimright $path \x00]
set f 4
foreach name "comment relativepath workingdir commandline icon" {
if {($array(flags) & $f) > 0} {
set len [getword $fh]
set array($name) [read $fh [expr {$len * 2}]]
}
set f [expr {$f * 2}]
}
return [array get array]
}
array set blah [readlnk $argv]
parray blah
if {$blah(final) == ""} {
puts "--> $blah(base)"
} else {
puts "--> $blah(base)\\$blah(final)"
}Another simple way, if you have Cygwin (RS):
exec ln -s /path/to/this/file that
Related information appears in "Windows specific Tcl commands". Microsoft Windows and Tcl - Arts and crafts of Tcl-Tk programming - Windows shortcut