VBA Snelkoppeling naar folder op bureaublad

[SjofaaSj]

Ik gebruik al jaren onderstaande code om een snelkoppeling naar de actieve file te plaatsen op het bureaublad.

Sub Link_Desktop ()
    Dim objScriptingHost As Object
    Dim objShortcut As Object
    Dim strShortcut As String
    Dim lngShortcut As Long
    Dim SaveLoc As String
    Dim myPath, myNameExt As String, myPathNameExt
    'parameters
    SaveLoc = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
    With ActiveWorkbook
        myPath = .Path
        myNameExt = .Name
        myPathNameExt = .FullName
    End With
    If InStr(myPath, "intranet") > 0 Then
        myPath = Replace(myPath, "http://intranet/", "https://intranet.MyCompany.com/")
        myPathNameExt = Replace(Replace(Replace(Replace(myPathNameExt, "http://intranet/", "https://intranet.MyCompany.com/"), "/", "\"), "http:", ""), " ", "%20")
    End If
    'proceed
    Set objScriptingHost = Nothing
    On Error Resume Next
    Set objScriptingHost = GetObject(, "WScript.Shell")
    On Error GoTo 0
    If objScriptingHost Is Nothing Then
        Set objScriptingHost = CreateObject("WScript.Shell")
    End If
    strShortcut = Dir(SaveLoc)
    Do While strShortcut <> vbNullString
        If InStr(strShortcut, "LINK - " & myNameExt) <> 0 Then
            lngShortcut = lngShortcut + 1
        End If
        strShortcut = Dir
    Loop
    If lngShortcut <> 0 Then myNameExt = myNameExt & "_(" & lngShortcut & ")"
    strShortcut = SaveLoc & "LINK - " & myNameExt & ".lnk"
    Set objShortcut = objScriptingHost.CreateShortcut(strShortcut)
    With objShortcut
        .TargetPath = myPathNameExt
        .Save
    End With
    Set objScriptingHost = Nothing
    Set objShortcut = Nothing
    CreateObject("WScript.Shell").Popup _
            "LINK               -->  " & myNameExt & vbLf & _
            "CREATED IN  -->  " & UCase(SaveLoc), 2, "CREATED LINK TO DESKTOP"
End Sub

Nu zoek ik een gelijkaardige manier om een desktop-snelkoppeling te maken naar de Parent Folder van de actieve file.
Ik probeerde met deze code te verwijzen naar het path ipv de naam vd file, maar krijg telkens de melding dat de snelkoppeling niet kan worden opgeslaan.
Iemand een idee hoe aan te passen?

 

[alphamax]

[SIZE=1]Sub Link_Folder()
    Dim objScriptingHost As Object
    Dim objShortcut As Object
    Dim strShortcut As String
    Dim myPath As String
    Dim myNameExt As String
    Dim myPathNameExt As String
        With ActiveWorkbook
            myPath = .Path
            myNameExt = .Name
            myPathNameExt = .FullName
        End With
        myPath = myPath & Application.PathSeparator
        On Error Resume Next
        Set objScriptingHost = GetObject(, "WScript.Shell")
        On Error GoTo 0
        If objScriptingHost Is Nothing Then
            Set objScriptingHost = CreateObject("WScript.Shell")
        End If
        strShortcut = myPath & "LINK - " & myNameExt & ".lnk"
        Set objShortcut = objScriptingHost.CreateShortcut(strShortcut)
        With objShortcut
            .TargetPath = myPathNameExt
            .Save
        End With
        Set objScriptingHost = Nothing
        Set objShortcut = Nothing
        CreateObject("WScript.Shell").Popup _
                "LINK               -->  " & myNameExt & vbLf & _
                                           "CREATED IN  -->  " & UCase(myPath), 2, "CREATED LINK TO DESKTOP"
End Sub[/SIZE]

 

[snb]

Sub M_snb()
  With CreateObject("WScript.Shell")
    With .CreateShortcut(.SpecialFolders("Desktop") & "\pad.lnk")
      .TargetPath = ThisWorkbook.Path & "\"
      .Save
    End With
  End With
End Sub

 

[SjofaaSj]

Dankjewel beiden.

SNB, verbazend hoe kort de code is geworden...

Alphamax, jouw code maakt hier een link naar de file ipv naar de map waar die file inzit?