Macro to add desktop shortcut

[hungledink]

Hi,

I've made an excel workbook that basically just adds a desktop shortcut to another excel file when a user clicks a custom button. This works as intended if I specify the full drive path and file name in the macro.

My problem is, that we use a shared drive at work, and people have assigned this shared drive to different letters, some have it as drive Z, others drive K and so on.

If I send it out via email therefore, the macro wont know which drive letter is assigned as the active shared drive.

Is there any way around this?

Here is the code I found online to create the desktop shortcut, I modified it slightly.

Sub CreateShortCut()
Dim oWSH As Object
Dim oShortcut As Object
Dim sPathDeskTop As String

Set oWSH = CreateObject("WScript.Shell")
sPathDeskTop = oWSH.SpecialFolders("Desktop")

Set oShortcut = oWSH.CreateShortCut(sPathDeskTop & "\" & _
ActiveWorkbook.Name & ".lnk")
With oShortcut
.TargetPath = ActiveWorkbook.FullName
.Save
End With
Set oWSH = Nothing

End Sub

Hopefully that makes sense.

Thanks in advance.

 

[GWteB]

Do not know whether you've already tried your macro, but afaik in a network environment the desktop of the logged on user is part of his/hers profile and independent of to which drive letter the share is mounted. In the environment I work with the desktop folder is on C:\Users\GWteB (regardless of thin or dedicated cliënt) and made read-only by te guys of the IT dept.

 

[hungledink]

I should have added that the shortcut does install on the desktop with the intended name so that part works fine.

It's just that it doesn't link to anything since it doesn't know the drive letter and therefore the correct file path.

 

[GWteB]

It's just that it doesn't link to anything since it doesn't know the drive letter and therefore the correct file path.

The red colored line in your code should take care of that, since the FullName property returns drive & folder & workbook file name.

With oShortcut
.TargetPath = ActiveWorkbook.FullName
.Save
End With

EDIT:

It's necessary for user's to save the attached workbook first on there share before your macro runs since e-mail attachements are extracted to a temporarily folder.

 

[hungledink]

Thanks for the info. It's the user having to save the file first I'm trying to avoid. I want it to work just from the email attachment

 

[GWteB]

You cannot create a shortcut to an attachment of an e-mail. The attachment - in this case an Excel workbook - has to be extracted and permanently saved on disk first.
Besides the difference in drive letters is the folder structure the same for every user? If that's the case there might be a way to determine the drive letter for the current user.

 

[hungledink]

Everything else is the same apart from the drive letter

 

[GWteB]

Since I've overlooked this part of your post #1 ...

a desktop shortcut to another excel file when a user clicks a custom button.

I think the code below does as required. Note the separate procedure. See if this works for you.

Public Sub Hungledink()
    
    Const FROM_ROOT_TO_FILE As String = "\Folder\SubFolder\Workbook.xlsx"       ' <<<< Change to suit (without drive letter!)

    Dim FSO As Object, oDrives As Object, oDrive As Object, FullFileName As String

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set oDrives = FSO.Drives
    For Each oDrive In oDrives
        If oDrive.IsReady Then
            FullFileName = oDrive.DriveLetter & ":" & FROM_ROOT_TO_FILE
            If CreateShortCutOnDesktop(FullFileName) Then
                Exit For
            End If
        End If
    Next oDrive
End Sub


Public Function CreateShortCutOnDesktop(ByVal argFullFileName As String) As Boolean
    
    Dim oWSH As Object
    Dim oShortcut As Object
    Dim sPathDeskTop As String
    Dim LinkName As String, FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(argFullFileName) Then
        LinkName = FSO.GetFileName(argFullFileName) & ".lnk"
        Set oWSH = CreateObject("WScript.Shell")
        sPathDeskTop = oWSH.SpecialFolders("Desktop")
        Set oShortcut = oWSH.CreateShortCut(sPathDeskTop & "\" & LinkName)
        With oShortcut
            .TargetPath = argFullFileName
            .Save
        End With
        CreateShortCutOnDesktop = True
    End If
End Function