[Summary view] [Print] [Text view]

   1  # Script to create a shortcut, including support for "special folders"
   2  # (like AllUsersDesktop).
   3  
   4  use warnings;
   5  use strict;
   6  use Getopt::Long;
   7  use Pod::Usage;
   8  use Win32::OLE;
   9  
  10  use File::Basename;
  11  use File::Spec;
  12  use File::Path;
  13  
  14  # Your usual option-processing sludge.
  15  my %opts;
  16  GetOptions (\%opts, 'help|h|?', 'arguments=s', 'description=s',
  17              'hotkey=s', 'icon=s', 'workingdirectory=s')
  18      or pod2usage (2);
  19  
  20  (exists $opts{'help'})
  21      and pod2usage ('-exitstatus' => 0, '-verbose' => 2);
  22  
  23  # Ensure exactly two arguments after options.
  24  scalar @ARGV == 2
  25      or pod2usage (2);
  26  
  27  my ($target, $shortcut) = @ARGV;
  28  
  29  # Bomb out completely if COM engine encounters any trouble.
  30  Win32::OLE->Option ('Warn' => 3);
  31  
  32  # Get WshShell object.  See
  33  # <http://msdn.microsoft.com/library/en-us/script56/html/wsobjwshshell.asp>
  34  my $wsh_shell = Win32::OLE->CreateObject ('WScript.Shell');
  35  
  36  sub canonicalize_filename ($) {
  37      my ($filename) = @_;
  38  
  39      # FIXME: Add support for "ProgramFiles".  And for "QuickLaunch";
  40      # see <http://www.winnetmag.com/Files/07/9176/Listing_03.txt>.
  41      if ($filename =~ /^special:([a-z]+)(.*)/i) {
  42          my ($special, $rest) = ($1, $2);
  43          # Get special folder.  See
  44          # <http://msdn.microsoft.com/library/en-us/script56/html/wsprospecialfolders.asp>
  45  
  46          my $folder = $wsh_shell->SpecialFolders ($special);
  47          $filename = "$folder$rest";
  48      }
  49  
  50      return $filename;
  51  }
  52  
  53  $target = canonicalize_filename ($target);
  54  $shortcut = canonicalize_filename ($shortcut);
  55  
  56  my ($shortcut_type, $shortcut_name, $shortcut_dir, $target_dir);
  57  
  58  if ($target =~ /^[a-z]+:\/\//i) {
  59      # Target looks like a URL, so create a URL shortcut.
  60      $shortcut_type = '.url';
  61      (exists $opts{'description'})
  62          and $shortcut_name = $opts{'description'};
  63  }
  64  else {
  65      # Create a traditional shortcut.
  66      $shortcut_type = '.lnk';
  67      # By defaut, name the shortcut after the target.
  68      my ($target_name, $target_ext);
  69      ($target_name, $target_dir, $target_ext) = fileparse ($target, qr{\..*});
  70      
  71      if ($target_ext =~ m/.*/i) {
  72          $shortcut_name = $target_name . $target_ext;
  73      }
  74  }
  75  
  76  if ($shortcut =~ /\\\z/ || -d $shortcut) {
  77      # Argument is a directory, so create the shortcut inside it.
  78      $shortcut_dir = $shortcut;
  79  }
  80  else {
  81      my $shortcut_ext;
  82      # Treat shortcut as a full path.
  83      ($shortcut_name, $shortcut_dir, $shortcut_ext)
  84          = fileparse ($shortcut, qr{\..*});
  85      if ($shortcut_ext =~ m/.*/i) {
  86          $shortcut_name = $shortcut_name . $shortcut_ext;
  87      }
  88  
  89  }
  90  
  91  defined $shortcut_name
  92      or die "URL shortcuts need a description or a full path ; bailing out";
  93  
  94  mkpath ($shortcut_dir);
  95  
  96  my $full_shortcut = File::Spec->catfile ($shortcut_dir,
  97                                           "$shortcut_name$shortcut_type");
  98  
  99  print "Creating shortcut $full_shortcut -> $target\n";
 100  
 101  # See
 102  # <http://msdn.microsoft.com/library/en-us/script56/html/wsobjwshshortcut.asp>
 103  # <http://msdn.microsoft.com/library/en-us/script56/html/wsobjwshurlshortcut.asp>
 104  
 105  my $obj = $wsh_shell->CreateShortcut ($full_shortcut);
 106  $obj->{TargetPath} = $target;
 107  
 108  if ($shortcut_type eq '.lnk') {
 109      # These properties only exist on traditional shortcuts.
 110      $obj->{WindowStyle} = 1;
 111  
 112      $obj->{IconLocation} = (exists $opts{'icon'}
 113                              ? $opts{'icon'}
 114                              : "$target, 0");
 115  
 116      $obj->{WorkingDirectory} = (exists $opts{'workingdirectory'}
 117                                  ? $opts{'workingdirectory'}
 118                                  : $target_dir);
 119  
 120      (exists $opts{'arguments'})
 121          and $obj->{Arguments} = $opts{'arguments'};
 122  
 123      (exists $opts{'description'})
 124          and $obj->{Description} = $opts{'description'};
 125  
 126      (exists $opts{'hotkey'})
 127          and $obj->{Hotkey} = $opts{'hotkey'};
 128  }
 129  
 130  $obj->Save ();
 131  
 132  exit 0;
 133  
 134  __END__
 135  
 136  =head1 NAME
 137  
 138  shortcut.pl - Create a Windows shortcut
 139  
 140  =head1 SYNOPSIS
 141  
 142  shortcut.pl [ options ] <target> <shortcut>
 143  
 144  Options (may be abbreviated):
 145  
 146   --help                   Display help and exit
 147   --arguments <args>       Use <args> as arguments to target
 148   --description <desc>     Set description (aka. "infotip") to <desc>
 149   --hotkey <key>           Set hotkey (aka. "keyboard shortcut") to <key>
 150   --icon <iconfile>        Set <iconfile> as the file containing the icon
 151   --workingdirectory <dir> Set working directory to <dir>
 152  
 153  =head1 DESCRIPTION
 154  
 155  This script creates a shortcut from <shortcut> to <target>.  If the
 156  string "special:<xxx>" appears in either argument, it will be replaced
 157  by the full path to the special folder <xxx>.  (Follow the link under
 158  SEE ALSO for a complete list of special folders.)
 159  
 160  If the <shortcut> argument is a directory, the shortcut will be
 161  created within.
 162  
 163  The WorkingDirectory property of the shortcut may be set by the
 164  "--workingdirectory" option; it defaults to the directory of the
 165  target.
 166  
 167  If the target looks like a URL, an Internet shortcut will be created.
 168  In this case, you must either provide the "--description" option or
 169  give a complete path for the shortcut.  (A default name derived from
 170  the URL would include slashes and colons, which are illegal in
 171  shortcut names.)
 172  
 173  =head1 EXAMPLES
 174  
 175   shortcut.pl "C:\Program Files\Foo\foo.exe" special:AllUsersDesktop
 176  
 177   shortcut.pl --description Unattended http://unattended.sourceforge.net/ special:Desktop
 178  
 179   shortcut.pl --description "My Foo shortcut" "C:\foo\foo.exe" special:AllUsersStartMenu
 180  
 181   shortcut.pl C:\foo\foo.exe --arguments "-x \"hi there\" -y" special:Desktop
 182  
 183  The last example creates a shortcut to invoke 'C:\foo\foo.exe -x "hi
 184  there" -y'.
 185  
 186  =head1 SEE ALSO
 187  C<http://msdn.microsoft.com/library/en-us/script56/html/wsprospecialfolders.asp>