Create a Desktop Shortcut for a New Folder

DragonWood · Nov 5, 2011

Ok, I have a VBA code that uses input boxes to ask the user for three names. It then uses one of the names to make a folder (if it doesn’t already exist). It uses another of the names to make another folder inside the first folder (if that folder doesn’t already exist). Finally, it uses the third name to make another folder (which wouldn’t exist before this) and uses a SaveAs to put a new copy of the workbook in that folder, also using the third name.
This works wonderfully, however, I would like to place a shortcut to the Third Folder on the desktop. I would prefer it to use this same macro so it all happens at once rather than counting on the user to do it.

I appreciate any help I can get.

AlphaFrog · Nov 5, 2011

Here is example VBA code for creating a desktop shortcut for the active workbook. It should do what you want with a little modification.

Create a Custom Desktop Shortcut

Trebor76 · Nov 5, 2011

For reference - this has been cross-posted here where I about to post a potential solution

DragonWood · Nov 6, 2011

I realize I put the same message both here and on VBA Express ( http://www.vbaexpress.com/forum/showthread.php?p=253943#post253943 ) but I figured there were

probably people that were members of one but not the other board that could help. I apologize if this is against the guidelines.

Anyway, I played with the code you referenced. If I copy that code directly into a workbook and link it to a button, it works great. However, when I

manipulate it so I can put it inside the code I am using to create the folder in the first place it doesn’t work.

The code that creates the folders works and there are no errors with that, however, the shortcut is not created and the Error Message Box appears.

Here is my full code with the changes made by manipulating the reference you provided.

Code:

Sub SaveToFolder(control As IRibbonControl)
'Saves the file to a set folder path based on the cell values on the Surveys page

'Declare the Variables for Saving the File
    Dim fileSaveName As String
    Dim locationSaveName As String
    Dim siteSaveName As String
    Dim compSaveName As String

'Declare the Variables for the Directory Path
    Dim fileRootPath As String
    Dim fileSavePath As String
    Dim dirDepth As Long
    Dim nextDir As Long
    Dim tempDir As String
    Dim x As Long

'Declare the Varialbles for the Input Boxes
    Dim compInput As String
    Dim locationInput As String
    Dim siteInput As String

'Declare the Varibles for the Message Boxes
    Dim msgCreate As String
    Dim msgStyle As String
    Dim msgTitle As String

'Declare the Constants for the Shortcut
    Const sctLocation As String = "Desktop"
    Const sctLinkExt As String = ".lnk"

'Declare the Objects for the Shortcut
    Dim oFolder As Object
    Dim oShortcut As Object

'Declare the variables for the Shortcut Path
    Dim sctDeskTopPath As String
    Dim sctShortcut As String


 
 'Unhide the sheets if still hidden
    
    ActiveWorkbook.Unprotect Password:="Password"
    
    Dim ws As Worksheet
        Application.DisplayAlerts = False
    For Each ws In ActiveWorkbook.Worksheets
        ws.Visible = True
    Next ws
        Application.DisplayAlerts = True
    
    ActiveWorkbook.Protect Password:="Password"
 
 'Make the Surveys page the focus point
 
    Application.Goto Sheets("Surveys").Range("A1"), True
    
 'Check the Company Name, Location Name, and Site Name fields for content. If there, use the content, if not provide an input box for entering the data.
 
    With Sheets("Surveys")
    If .Range("D2").Value = "" Then
        .Range("D2").Select
        compInput = InputBox("Please enter the Company Name.", "Company Name")
        ActiveCell.FormulaR1C1 = compInput
    End If
    If .Range("D5").Value = "" Then
        .Range("D5").Select
        locationInput = InputBox("Please fill in the Location Name.", "Location Name")
        ActiveCell.FormulaR1C1 = locationInput
    End If
    If .Range("D6").Value = "" Then
        .Range("D6").Select
        siteInput = InputBox("Please fill in the Site Name.", "Site Name")
        ActiveCell.FormulaR1C1 = siteInput
    End If
    
        fileSaveName = CleanFileName(.Range("D5").Value) & " - Cross Section" & ".xlsm"
        locationSaveName = CleanFileName(.Range("D5").Value) & "\"
        siteSaveName = CleanFileName(.Range("D6").Value) & "\"
        compSaveName = CleanFileName(.Range("D2").Value) & "\"
    End With
    
 'Set the Root Path
 
    fileRootPath = "C:\Clients\Locations\"
    
 'Set the sub paths
 
    fileSavePath = fileRootPath & compSaveName & siteSaveName & locationSaveName
    
 'Check for directory name, use it if there, create it if not
 
    If Dir(fileSavePath, vbDirectory) = "" Then
        dirDepth = Len(fileSavePath) - Len(Replace(fileSavePath, "\", ""))
        nextDir = InStr(fileSavePath, "\")
        For x = 1 To dirDepth - 1
            nextDir = InStr(nextDir + 1, fileSavePath, "\")
            tempDir = Left(fileSavePath, nextDir)
            If Dir(tempDir, vbDirectory) = "" Then MkDir tempDir
        Next x
    End If
    
'Save the workbook under the new directory and name

    ActiveWorkbook.SaveAs Filename:=fileSavePath & fileSaveName

On Error Goto ErrHandle 
'Determine the path to the Desktop
    Set oFolder = CreateObject("WScript.Shell")
    sctDeskTopPath = oFolder.SpecialFolders(sctLocation)

'Determine the location of the Shortcut
    sctShortcut = sctDeskTopPath & fileSavePath & sctLinkExt

'Create the Shortcut
    Set oShortcut = oFolder.CreateShortCut(sctShortcut)

'Establish the link to the File
    With oShortcut
        .TargetPath = fileSavePath
         .Save
    End With

'Clear Memory
    Set oFolder = Nothing
    Set oShortcut = Nothing

'Display the Success Message
    msgCreate = "The file can be found here: " & Filename & vbNewLine
    msgCreate = msgCreate & "There is a shortcut to the folder on your desktop."
    msgStyle = 0 
    msgTitle = "The file was created successfully" 
    MsgBox msgCreate, msgStyle, msgTitle 
     
     
    Exit Sub 
     
     
'Display the Error Message
ErrHandle: 
    msgCreate = "Please close and reopen the original file." 
    msgStyle = 48 
    msgTitle = "The file was not created" 
    MsgBox msgCreate, msgStyle, msgTitle 
    
End Sub

Function CleanFileName(sFileName As String, Optional ReplaceInvalidwith As String = "") As String
    'Removes invalid filename characters
    
    Const InvalidChars As String = "%~:\/?*<>|"""
    Dim ThisChar As Long
    CleanFileName = sFileName
    For ThisChar = 1 To Len(InvalidChars)
        CleanFileName = Replace(CleanFileName, Mid(InvalidChars, ThisChar, 1), ReplaceInvalidwith)
    Next
End Function

I appreciate any help I can get with this.

Thanks.

AlphaFrog · Nov 6, 2011

Two problems when you created the folder shortcut:

Need to add a path separator \ at the end of the desktop path
Can't name the shortcut using the full file path. The : and \ are not valid shortcut naming characters.

This crates the shortcut and names it as the last sub-folder in the file path

Code:

[COLOR="Green"]'Determine the location of the Shortcut[/COLOR]
    [COLOR="Red"]sctShortcut= Mid(fileSavePath, InStrRev(fileSavePath, "\") + 1)[/COLOR]
    sctShortcut = sctDeskTopPath & [COLOR="Red"]Application.PathSeparator & sctShortcut &[/COLOR] sctLinkExt

DragonWood · Nov 6, 2011

That works nicely. Thanks.

Create a Desktop Shortcut for a New Folder

DragonWood

Board Regular

Excel Facts

AlphaFrog

MrExcel MVP

Trebor76

Well-known Member

DragonWood

Board Regular

AlphaFrog

MrExcel MVP

DragonWood

Board Regular

Similar threads

Forum statistics

Share this page

Create a Desktop Shortcut for a New Folder

DragonWood

Board Regular

Excel Facts

AlphaFrog

MrExcel MVP

Trebor76

Well-known Member

DragonWood

Board Regular

AlphaFrog

MrExcel MVP

DragonWood

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock