Creating shortcut to folder

[rogerm]

I am using the vba code below to create desktop shortcuts to workbooks.
Could anyone help me with the code to to create a shortcut to open a the folder containing the workbooks rather than the workbook itself. Thanks

Function fCreateShortcutOnDesktop(strFullFilePathName As String) _
As Long


Dim WSHShell As IWshRuntimeLibrary.IWshShell_Class
Dim WSHShortcut As IWshRuntimeLibrary.IWshShortcut_Class
Dim strDesktopPath As String
Dim strFileName As String
Dim strPath As String

On Error GoTo fCreateShortcutOnDesktop_Err

' Create a Windows Shell Object
Set WSHShell = New IWshRuntimeLibrary.IWshShell_Class

' Get the file's name and path...
strFileName = Dir(strFullFilePathName)
strPath = Left(strFullFilePathName, _
Len(strFullFilePathName) - Len(strFileName))

' Make sure file exists
If Not Len(strFileName) = 0 Then

' Read desktop path using WshSpecialFolders object
strDesktopPath = WSHShell.SpecialFolders.Item("Desktop")

' Create a shortcut object on the desktop
Set WSHShortcut = WSHShell.CreateShortcut _
(strDesktopPath & "\" & strFileName & ".lnk")

' Set shortcut object properties and save it
With WSHShortcut
.TargetPath = WSHShell. _
ExpandEnvironmentStrings(strFullFilePathName)
.WorkingDirectory = WSHShell. _
ExpandEnvironmentStrings(strPath)
.WindowStyle = 4
.IconLocation = WSHShell. _
ExpandEnvironmentStrings(Application.Path _
& "\excel.exe ,0")
.Save
End With
fCreateShortcutOnDesktop = 1
Else
fCreateShortcutOnDesktop = 0
End If
Continue:
' Tidy Up
Set WSHShell = Nothing
Exit Function

fCreateShortcutOnDesktop_Err:
fCreateShortcutOnDesktop = -1
Resume Continue
End Function