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:
- 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.
- 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.
- 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
Technical Architect | DevOps Evangelist | Software Developer | Microsoft, NVIDIA, Citrix and Desktop Virtualisation (VDI) Specialist/Expert | Rapper | Improvisor | Comedian | Property Investor | Kayaking enthusiast at J House Consulting
Jeremy Saunders is the Problem Terminator. He is a highly respected IT Professional with over 35 years’ experience in the industry. Using his exceptional design and problem solving skills with precise methodologies applied at both technical and business levels he is always focused on achieving the best business outcomes. He worked as an independent consultant until September 2017, when he took up a full time role at BHP, one of the largest and most innovative global mining companies. With a diverse skill set, high ethical standards, and attention to detail, coupled with a friendly nature and great sense of humour, Jeremy aligns to industry and vendor best practices, which puts him amongst the leaders of his field. He is intensely passionate about solving technology problems for his organisation, their customers and the tech community, to improve the user experience, reliability and operational support. Views and IP shared on this site belong to Jeremy.
Latest posts by Jeremy Saunders (see all)
- Best Practice for the Active Setup StubPath value - September 25, 2023
- User Profile Migration Strategy and PowerShell Script with a User Interface - August 28, 2023
- Cold Starting and/or Hydrating Your Applications To Improve Their Startup Times - June 27, 2023