VBA to generate a file shortcut

[sassriverrat]

I'm trying to get a piece a code that can generate a shortcut for a folder I generated via code. It would be really nice if I could change the icon as well to an object that's on a page in the workbook, but that's secondary.

So:
1. Makes an shortcut for a folder specified in code.
2. Makes a shortcut to x location
3. Makes an icon from a picture on page 1 of the workbook.

Option Explicit Sub CreateDesktopShortcut()     ' =================================================================     ' Create a custom icon shortcut on the users desktop     ' =================================================================         ' Msgbox string variables    Dim szMsg As String    Dim szStyle As String    Dim szTitle As String             ' Change here for the icon's name    Const szIconName As String = "\cvg.ico"             ' Constant string values, you can replace "Desktop"     ' with any Special Folders name to create the shortcut there    Const szlocation As String = "Desktop"    Const szLinkExt As String = ".lnk"             ' Object variables    Dim oWsh As Object    Dim oShortcut As Object             ' String variables    Dim szSep As String    Dim szBookName As String    Dim szBookFullName As String    Dim szPath As String    Dim szDesktopPath As String    Dim szShortcut As String             ' Initialize variables    szSep = Application.PathSeparator    szBookName = szSep & ThisWorkbook.Name    szBookFullName = ThisWorkbook.FullName    szPath = ThisWorkbook.Path                On Error GoTo ErrHandle     ' The WScript.Shell object provides functions to read system     ' information and environment variables, work with the registry     ' and manage shortcuts    Set oWsh = CreateObject("WScript.Shell")    szDesktopPath = oWsh.SpecialFolders(szlocation)             ' Get the path where the shortcut will be located    szShortcut = szDesktopPath & szBookName & szLinkExt             ' Make it happen    Set oShortcut = oWsh.CreateShortCut(szShortcut)             ' Link it to this file    With oShortcut        .TargetPath = szBookFullName        .IconLocation = szPath & szIconName        .Save    End With             ' Explicitly clear memory    Set oWsh = Nothing    Set oShortcut = Nothing             ' Let the user know it was created ok    szMsg = "Shortcut was created successfully"    szStyle = 0    szTitle = "Success!"    MsgBox szMsg, szStyle, szTitle            Exit Sub             ' or if it wasn't ErrHandle:    szMsg = "Shortcut could not be created"    szStyle = 48    szTitle = "Error!"        MsgBox szMsg, szStyle, szTitle End Sub

 

[Logit]

Sub CreateDesktopShortcut()
     ' =================================================================
     ' Create a custom icon shortcut on the users desktop
     ' =================================================================
    
     ' Msgbox string variables
    Dim szMsg As String
    Dim szStyle As String
    Dim szTitle As String
    
    
     ' Change here for the icon's name
    Const szIconName As String = "\cvg.ico"
    
    
     ' Constant string values, you can replace "Desktop"
     ' with any Special Folders name to create the shortcut there
    Const szlocation As String = "Desktop"
    Const szLinkExt As String = ".lnk"
    
    
     ' Object variables
    Dim oWsh As Object
    Dim oShortcut As Object
    
    
     ' String variables
    Dim szSep As String
    Dim szBookName As String
    Dim szBookFullName As String
    Dim szPath As String
    Dim szDesktopPath As String
    Dim szShortcut As String
    
    
     ' Initialize variables .......................... This is where you would edit to create the Icon & Shortcut you want.
    szSep = Application.PathSeparator
    szBookName = szSep & ThisWorkbook.Name
    szBookFullName = ThisWorkbook.FullName
    szPath = ThisWorkbook.Path
    
    
    
    On Error GoTo ErrHandle
     ' The WScript.Shell object provides functions to read system
     ' information and environment variables, work with the registry
     ' and manage shortcuts
    Set oWsh = CreateObject("WScript.Shell")
    szDesktopPath = oWsh.SpecialFolders(szlocation)
    
    
     ' Get the path where the shortcut will be located
    szShortcut = szDesktopPath & szBookName & szLinkExt
    
    
     ' Make it happen
    Set oShortcut = oWsh.CreateShortCut(szShortcut)
    
    
     ' Link it to this file
    With oShortcut
        .TargetPath = szBookFullName
        .IconLocation = szPath & szIconName
        .Save
    End With
    
    
     ' Explicitly clear memory
    Set oWsh = Nothing
    Set oShortcut = Nothing
    
    
     ' Let the user know it was created ok
    szMsg = "Shortcut was created successfully"
    szStyle = 0
    szTitle = "Success!"
    MsgBox szMsg, szStyle, szTitle
    
    
    Exit Sub
    
    
     ' or if it wasn't
ErrHandle:
    szMsg = "Shortcut could not be created"
    szStyle = 48
    szTitle = "Error!"
    
    MsgBox szMsg, szStyle, szTitle
End Sub

Paste the above in a macro, save the workbook, then run. It will create a shortcut on the desktop to the workbook.
As indicated in the code, you can edit the section marked to create a shortcut for any workbook or file desired.

At the beginning of the macro is where you designate which icon you want for the shortcut.


Here is a slightly shorter version :

Option Explicit

Sub test()

'Step 3: Create a desktop shortcut for the project file
Dim pWsh
Dim dShortCut, fShortCut, pShortCut, wName, dPath, fPath, EnvironName As String

'On Error GoTo Proc_Err
        Set pWsh = CreateObject("WScript.Shell")
        wName = ThisWorkbook.Name & ".ico"              'change ".ico" to complete icon name
        dShortCut = pWsh.SpecialFolders("Desktop")
        fShortCut = dShortCut & "\" & wName & ".lnk"
        
        fPath = "C:\Users\" & EnvironName & "\Desktop\" & wName
            Set pShortCut = pWsh.CreateShortcut(fShortCut)
            With pShortCut
                .TargetPath = dPath
                .RelativePath = dPath
                .WorkingDirectory = dPath
                .IconLocation = fPath
                '.iconname = wName                      'uncomment this line
                .Save
            End With
Proc_Exit:
           On Error Resume Next
           Set pShortCut = Nothing
           Set pWsh = Nothing
           Exit Sub
Proc_Err:
            If Err.Number <> 0 Then
                MsgBox Err.Description & " !", vbCritical, "Critical Error # " & Err.Number
            End If
            Set pShortCut = Nothing
            Set pWsh = Nothing
End Sub

 

[sassriverrat]

So the good and the bad.
As you saw, the first code you posted is the same that I posted (formatting is just odd on mine). The good is that the first code works well, but I don't how to change the location (As I see you can in the second code) and I don't know how to change the icon itself (picture).

 

[sassriverrat]

bump