VB and VBA Users Source Code: Create a short cut to a file
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Create a short cut to a file
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Monday, January 15, 2001
Hits:
876
Category:
Files/Directories/IO
Article:
The following routine creates a shortcuts (.lnk files) to a specified file using the Windows Scripting Host, including setting the icon and passing command line arguments. Note, a demonstration routine can be found at the end of this post. Option Explicit 'Purpose : Creates a Shortcut (or .lnk file) using the windows scripting host 'Inputs : sTarget The location of the file to make a shortcut to. ' [sLinkFileName] The path and file name to save the shortcut to (default path is desktop) ' eg, "<Desktop>\My shortcut.lnk" (see the *Special Folders note for details). ' or "C:\My shortcut.lnk". ' [sIconLocation] The icon location (default uses the icon associated with the file at sTarget). ' [sWorkingDirectory] The working directory of the short cut. ' [lWindowStyle] 3=Maximized, 7=Minimized and 4=Normal. Defaults to normal. ' [sParams] Any command line arguments. 'Outputs : Returns zero on success, else returns an error number 'Author : Andrew Baker 'Date : 15/01/2001 22:34 'Notes : Requires Microsoft Windows Script Host Object Model (WSHOM.OCX) ' *Special Folders are "AllUsersDesktop", "AllUsersStartMenu", "AllUsersPrograms" ' "AllUsersStartup", "Desktop", "Favorites", "Fonts", "MyDocuments", "NetHood" ' "PrintHood", "Programs", "Recent", "SendTo", "StartMenu", "Startup", "Template" 'Revisions : Function CreateShortCut(sTarget As String, Optional ByVal sLinkFileName As String, Optional ByVal sIconLocation As String, Optional ByVal sWorkingDirectory As String, Optional bOverWrite As Boolean = False, Optional lWindowStyle As Long = 4, Optional sParams As String = "") As Long Dim oWshShell As Object 'IWshRuntimeLibrary.IWshShell_Class Dim oMyShortcut As Object 'IWshRuntimeLibrary.IWshShortcut_Class Dim sSpecialFolderName As String, sSpecialFolder As String, lSpecialIndex As Long On Error GoTo ErrFailed Set oWshShell = CreateObject("Wscript.shell") If Len(sLinkFileName) = 0 Then 'Use default, save shortcut to desktop sLinkFileName = oWshShell.SpecialFolders("Desktop") Else '*Return the path of a special folder sSpecialFolderName = StringSlice(sLinkFileName, "<", ">", True) If Len(sSpecialFolderName) Then Select Case sSpecialFolderName Case "AllUsersDesktop" lSpecialIndex = 0 Case "AllUsersStartMenu" lSpecialIndex = 1 Case "AllUsersPrograms" lSpecialIndex = 2 Case "AllUsersStartup" lSpecialIndex = 3 Case "Desktop" lSpecialIndex = 4 Case "Favorites" lSpecialIndex = 15 Case "Fonts" lSpecialIndex = 8 Case "MyDocuments" lSpecialIndex = 1 Case "NetHood" lSpecialIndex = 9 Case "PrintHood" lSpecialIndex = 6 Case "Programs" lSpecialIndex = 17 Case "Recent" lSpecialIndex = 13 Case "SendTo" lSpecialIndex = 12 Case "StartMenu" lSpecialIndex = 11 Case "Startup" lSpecialIndex = 14 Case "Template" lSpecialIndex = 16 Case Else lSpecialIndex = 0 End Select sSpecialFolder = oWshShell.SpecialFolders(lSpecialIndex) sLinkFileName = Replace(sLinkFileName, "<" & sSpecialFolderName & ">", sSpecialFolder) End If End If If Len(Dir$(sLinkFileName)) > 0 And Len(sLinkFileName) > 0 Then If bOverWrite = False Then 'Shortcut already exists Exit Function Else 'Overwrite existing file VBA.Kill sLinkFileName End If End If '---Create the shortcut Set oMyShortcut = oWshShell.CreateShortCut(sLinkFileName) oMyShortcut.WindowStyle = lWindowStyle If Len(sIconLocation) = 0 Then 'Use the application icon sIconLocation = sTarget End If oMyShortcut.IconLocation = sIconLocation If Len(Dir$(sWorkingDirectory)) > 0 And Len(sWorkingDirectory) > 0 Then oMyShortcut.WorkingDirectory = sWorkingDirectory End If oMyShortcut.TargetPath = sTarget oMyShortcut.Arguments = sParams oMyShortcut.Save Set oMyShortcut = Nothing Set oWshShell = Nothing Exit Function ErrFailed: Debug.Print "Error in CreateShortCut: " & Err.Description CreateShortCut = Err.Number On Error GoTo 0 End Function 'Purpose : Returns a sub string from within a string. 'Inputs : sValue The string to return a slice/portion of. ' sStartDelim The delimeter which denotes the start of the string ' [sEndDelim] The delimeter which denotes the end of the string ' [bTrimText] If True trims the resulting string. 'Outputs : Returns the requested portion of the string (without the delimeters). 'Author : Andrew Baker 'Date : 06/07/2001 'Notes : If it doesn't find the sEndDelim, will use the end of the string ' eg. ' StringSlice("DB=TEST_DB;USER=ANDREW","USER=",";") ' Returns "ANDREW" ' Design primarily for use with command line arguments 'Revisions : Function StringSlice(sValue As String, sStartDelim As String, sEndDelim As String, Optional bTrimText As Boolean = True) As String Dim lPosStart As Long, lPosEnd As Long, lLen As Long Dim lLenStartDelim As Long, lLenEndDelim As Long On Error GoTo ErrFailed 'Determine string properties lLen = Len(sValue) lLenStartDelim = Len(sStartDelim) lLenEndDelim = Len(sEndDelim) 'Find start delimeter lPosStart = InStr(1, sValue, sStartDelim, vbTextCompare) If lPosStart Then lPosStart = lPosStart + lLenStartDelim 'Find end delimeter lPosEnd = InStr(lPosStart, sValue, sEndDelim, vbTextCompare) If lPosEnd = 0 Then 'Did not find end delimeter, use the end of the string lPosEnd = lLen + 1 End If 'Return resulting string StringSlice = Mid$(sValue, lPosStart, lPosEnd - lPosStart) If bTrimText Then 'Trim leading and trailing spaces StringSlice = Trim$(StringSlice) End If End If Exit Function ErrFailed: Debug.Print "StringSlice Error: " & Err.Description On Error GoTo 0 End Function 'Demonstration routine Sub Test() 'Create a shortcut to notepad (in the windows directory) CreateShortCut "%windir%\notepad.exe", "c:\test.lnk", , "C:\" 'Create a shortcut to a workbook on the desktop CreateShortCut "D:\Book1.xls", "<Desktop>\book.lnk" End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
