The Challenges of Using VBScript to Create Shortcuts

by Jeremy Saunders on December 3, 2008

Updated 8th December 2008…

Today I was finalising the application deployment for a new XenApp farm. One of the final scripts to create was to place 9 shortcuts on the Desktop of the All Users profile. That’s quite a simple task, and for the most part some would probably just end up copying a bunch of previously created ones into place. But that would be too easy. I wanted to create them on the fly!

So whilst I was writing the script I was faced with three challenges:

    1. As per Microsoft KB article Q263324, when you create shortcuts and specify a long file name in the target path, the path is truncated if the hard disk (or drive mapping) for the target path does not exist.

For example, create a shortcut with the following target:

J:\Mydirectory\Myapplication.exe

If drive J does not exist, the path is truncated to:

J:\Mydirect\Mypplica.exe

This problem can occur because the shell cannot determine whether the hard disk supports long file names, so the path is truncated to be acceptable to all file systems. Amazing that this is still a problem in this day and age!

To work around this problem, you can use the subst command to point drive J to a local hard disk.

To subst a drive to make the mapping work…

ret = WshShell.Run (“cmd /c subst j: %SystemDrive%\”, 0, TRUE)

To remove the subst…

ret = WshShell.Run (“cmd /c subst j: /d”, 0, TRUE)

So to work around this problem I created a function called CreateSubstDrive that will create a virtual drive, and then delete it when finished.

  1. The IconLocation property that assigns an icon to a shortcut does not work for URL shortcuts. Only LNK shortcuts work with this property, so I had create a subroutine that opens the .URL file and appends the IconFile and IconIndex. However, if run after the deployment of IE7, the make up of the contents of the URL file is different. IE7 adds some more properties, including a GUID section. Since the origninal script was simply just appending the IconFile and IconIndex lines, and because IE6 only created URL shortcuts with one section called “[InternetShortcut]”, it was now being placed in the wrong “section”. So now we need to treat the URL file as an ini file. Therefore I have replaced the original AddURLIcon subroutine with a standard WriteINIString subroutine from Motobit Software.
  2. This script will error with a “Catastrophic failure” when creating any URL shortcuts if run after the deployment of IE7 and before a reboot. Even using “On Error Resume Next” to force the script to continue, fails to create the shortcuts correctly. Therefore, this script must either be run before the deployment of IE7, or after a reboot.
' This script will create the required Shortcuts
'
' Revision 1.1 released on 8th December 2008.
' Written by Jeremy@jhouseconsulting.com on 3rd December 2008.

Option Explicit

Dim objfso, objFolder, wshShell, oShellLink, strAUPrograms, strAUStartup, strAUDesktop
Dim strProgramFiles, strTargetPath, strScriptPath, strSystemRoot, strSystemDrive
Dim strProcessorArchitecture, blnActiveSubst, strIconFile, intIconIndex

set WshShell = WScript.CreateObject("WScript.Shell")
set objfso = CreateObject("Scripting.FileSystemObject")

strSystemDrive = WshShell.ExpandEnvironmentStrings("%SystemDrive%")
strSystemRoot = WshShell.ExpandEnvironmentStrings("%SystemRoot%")
strProcessorArchitecture = WshShell.ExpandEnvironmentStrings("%PROCESSOR_ARCHITECTURE%")
If strProcessorArchitecture = "x86" Then
  strProgramFiles = WshShell.ExpandEnvironmentStrings("%ProgramFiles%")
Else
  strProgramFiles = WshShell.ExpandEnvironmentStrings("%ProgramFiles(86)%")
End If
strAUPrograms = WshShell.SpecialFolders("AllUsersPrograms")
strAUStartup = WshShell.SpecialFolders("AllUsersStartup")
strAUDesktop = WshShell.SpecialFolders("AllUsersDesktop")
strScriptPath = GetCurrentPath

' ********************************************************************************

blnActiveSubst=False
If CreateSubstDrive("i","create") Then blnActiveSubst=True
Set oShellLink = WshShell.CreateShortcut(strAUDesktop & "\APM Springboard.lnk")
oShellLink.TargetPath = "I:\springboard\index.html"
oShellLink.WorkingDirectory = "I:\springboard"
oShellLink.IconLocation = "%SystemRoot%\system32\SHELL32.dll" & ",93"
oShellLink.Save
If blnActiveSubst then Call CreateSubstDrive("i","delete")

' ********************************************************************************

blnActiveSubst=False
If CreateSubstDrive("q","create") Then blnActiveSubst=True
Set oShellLink = WshShell.CreateShortcut(strAUDesktop & "\Case Manager.lnk")
oShellLink.TargetPath = chr(34) & "Q:\Case Manager\CaseManagerLoader.exe" & chr(34)
oShellLink.Arguments = "/DB:ODBC;DSN=CaseManager /nosplash"
oShellLink.WorkingDirectory = chr(34) & "Q:\CASEMA~1" & chr(34)
oShellLink.IconLocation = "Q:\Case Manager\CaseMan.exe" & ",0"
oShellLink.Save
If blnActiveSubst then Call CreateSubstDrive("q","delete")

' ********************************************************************************

Set oShellLink = WshShell.CreateShortcut(strAUDesktop & "\\ConnX.url")
oShellLink.TargetPath = "http://apm-wp-db001/connx/"
oShellLink.Save
If objFSO.FileExists(strScriptPath & "connx.ico") Then
  If NOT objFSO.FolderExists(strSystemDrive & "\Connx") Then
    Set objFolder = objFSO.CreateFolder(strSystemDrive & "\Connx")
  End If
  objFSO.CopyFile strScriptPath & "connx.ico", strSystemDrive & "\Connx\", True
  strIconFile=strSystemDrive & "\Connx\connx.ico"
  intIconIndex=0
  WriteINIString "InternetShortcut", "IconIndex", intIconIndex, strAUDesktop & "\\ConnX.url"
  WriteINIString "InternetShortcut", "IconFile", strIconFile, strAUDesktop & "\\ConnX.url"
End If

' ********************************************************************************

Set oShellLink = WshShell.CreateShortcut(strAUDesktop & "\\Crystal Reports Infoview.url")
oShellLink.TargetPath = "http://apm-wp-crystal2/businessobjects/enterprise115/InfoView/logon.aspx"
oShellLink.Save

' ********************************************************************************

blnActiveSubst=False
If CreateSubstDrive("j","create") Then blnActiveSubst=True
Set oShellLink = WshShell.CreateShortcut(strAUDesktop & "\Daily Update.lnk")
oShellLink.TargetPath = "J:\DailyUpdate\dailyupdate.html"
oShellLink.WorkingDirectory = "J:\DailyUpdate"
oShellLink.IconLocation = "%SystemRoot%\system32\SHELL32.dll" & ",13"
oShellLink.Save
If blnActiveSubst then Call CreateSubstDrive("j","delete")

' ********************************************************************************

Set oShellLink = WshShell.CreateShortcut(strAUDesktop & "\Desktop eForms.lnk")
oShellLink.TargetPath = chr(34) & strProgramFiles & "\Shana\Informed\Filler.exe" & chr(34)
oShellLink.IconLocation = strProgramFiles & "\Shana\Informed\Filler.exe" & ",0"
oShellLink.Save

' ********************************************************************************

Set oShellLink = WshShell.CreateShortcut(strAUDesktop & "\\HelpDesk Portal.url")
oShellLink.TargetPath = "http://helpdesk/Versacat"
oShellLink.Save

' ********************************************************************************

blnActiveSubst=False
If CreateSubstDrive("h","create") Then blnActiveSubst=True
Set oShellLink = WshShell.CreateShortcut(strAUDesktop & "\JobReady+ v8.lnk")
oShellLink.TargetPath = "H:\JobReady\JobReady_logon.fp7"
oShellLink.WorkingDirectory = "H:\JobReady"
oShellLink.IconLocation = "%ProgramFiles%\FileMaker\FileMaker Pro 8.5\FileMaker Pro.exe" & ",0"
oShellLink.Save
If blnActiveSubst then Call CreateSubstDrive("h","delete")

' ********************************************************************************

blnActiveSubst=False
If CreateSubstDrive("i","create") Then blnActiveSubst=True
Set oShellLink = WshShell.CreateShortcut(strAUDesktop & "\Resources.lnk")
oShellLink.TargetPath = "I:\springboard\onlineresources.htm"
oShellLink.WorkingDirectory = "I:\springboard"
oShellLink.IconLocation = "%SystemRoot%\system32\SHELL32.dll" & ",98"
oShellLink.Save
If blnActiveSubst then Call CreateSubstDrive("i","delete")

' ********************************************************************************

Set WshShell = Nothing
Set objfso = Nothing
Set objFolder = Nothing

WScript.Quit(0)

Function GetCurrentPath
' Return path to the current script
  DIM path
  path = WScript.ScriptFullName
  GetCurrentPath = Left(path, InstrRev(path, "\"))
End Function

Sub AddURLIcon(strShortCutPath,strIconFile,intIconIndex)
  Dim objfile,ots,line,contents,blnIconNotSet
  set objfile=objfso.getfile(strShortCutPath)
  set ots=objfile.openastextstream(1)
  contents=""
  do while not ots.atEndofstream
    line=ots.readline
    if instr(1,line,"IconIndex",1)=0 and instr(1,line,"IconFile",1)=0 then
      contents=contents & line & vbcrlf
    end if
  loop
  ots.close
  contents=contents & "IconFile=" & strIconFile & vbcrlf
  contents=contents & "IconIndex=" & cstr(intIconIndex)
  set ots=objfile.openastextstream(2)
  ots.write contents
  ots.close
  set ots=nothing
  set objfile=nothing
End Sub

Function CreateSubstDrive(strLetter,strAction)
  Dim ret, WshShell, objfso
  set WshShell = WScript.CreateObject("WScript.Shell")
  set objfso = CreateObject("Scripting.FileSystemObject")
  If lcase(strAction)="create" Then
    If NOT objfso.FolderExists(strLetter & ":\") Then
      ret = WshShell.Run ("cmd /c subst " & strLetter & ": %SystemDrive%\", 0, TRUE)
      CreateSubstDrive = True
    Else
      CreateSubstDrive = False
    End If
  End If
  If lcase(strAction)="delete" Then
    ret = WshShell.Run ("cmd /c subst " & strLetter & ": /d", 0, TRUE)
    CreateSubstDrive = True
  End If
  set WshShell = Nothing
  set objfso = Nothing
End Function

Sub WriteINIString(Section, KeyName, Value, FileName)
  Dim INIContents, PosSection, PosEndSection

' Get contents of the INI file As a string
  INIContents = GetFile(FileName)

' Find section
  PosSection = InStr(1, INIContents, "[" & Section & "]", vbTextCompare)
  If PosSection>0 Then
'   Section exists. Find end of section
    PosEndSection = InStr(PosSection, INIContents, vbCrLf & "[")
'   ?Is this last section?
    If PosEndSection = 0 Then PosEndSection = Len(INIContents)+1

'   Separate section contents
    Dim OldsContents, NewsContents, Line
    Dim sKeyName, Found
    OldsContents = Mid(INIContents, PosSection, PosEndSection - PosSection)
    OldsContents = split(OldsContents, vbCrLf)

'   Temp variable To find a Key
    sKeyName = LCase(KeyName & "=")

'   Enumerate section lines
    For Each Line In OldsContents
      If LCase(Left(Line, Len(sKeyName))) = sKeyName Then
        Line = KeyName & "=" & Value
        Found = True
      End If
      NewsContents = NewsContents & Line & vbCrLf
    Next

    If isempty(Found) Then
'     key Not found - add it at the end of section
      NewsContents = NewsContents & KeyName & "=" & Value
    Else
'     remove last vbCrLf - the vbCrLf is at PosEndSection
      NewsContents = Left(NewsContents, Len(NewsContents) - 2)
    End If

'   Combine pre-section, new section And post-section data.
    INIContents = Left(INIContents, PosSection-1) & _
    NewsContents & Mid(INIContents, PosEndSection)
  else'if PosSection>0 Then
'   Section Not found. Add section data at the end of file contents.
    If Right(INIContents, 2) <> vbCrLf And Len(INIContents)>0 Then
      INIContents = INIContents & vbCrLf
    End If
    INIContents = INIContents & "[" & Section & "]" & vbCrLf & _
    KeyName & "=" & Value
  end if'if PosSection>0 Then
  WriteFile FileName, INIContents
End Sub

Function GetFile(ByVal FileName)
  Dim FS: Set FS = CreateObject("Scripting.FileSystemObject")
' Go To windows folder If full path Not specified.
  If InStr(FileName, ":\") = 0 And Left (FileName,2)<>"\\" Then
    FileName = FS.GetSpecialFolder(0) & "\" & FileName
  End If
  On Error Resume Next

  GetFile = FS.OpenTextFile(FileName).ReadAll
End Function

Function WriteFile(ByVal FileName, ByVal Contents)

  Dim FS: Set FS = CreateObject("Scripting.FileSystemObject")
' On Error Resume Next

' Go To windows folder If full path Not specified.
  If InStr(FileName, ":\") = 0 And Left (FileName,2)<>"\\" Then
    FileName = FS.GetSpecialFolder(0) & "\" & FileName
  End If

  Dim OutStream: Set OutStream = FS.OpenTextFile(FileName, 2, True)
  OutStream.Write Contents
End Function

Enjoy!

Jeremy Saunders

Jeremy Saunders

Independent Consultant | Contractor | Microsoft & Citrix Specialist | Desktop Virtualization Specialist at J House Consulting
Jeremy is a highly respected, IT Professional, with over 30 years’ experience in the industry. He is an independent IT consultant providing expertise to enterprise, corporate, higher education and government clients. His skill set, high ethical standards, integrity, morals and attention to detail, coupled with his friendly nature and exceptional design and problem solving skills, makes him one of the most highly respected and sought after Microsoft and Citrix technical resources in Australia. His alignment with industry and vendor best practices puts him amongst the leaders of his field.
Jeremy Saunders
Jeremy Saunders
Jeremy Saunders

Previous post:

Next post: