'Requires a reference to ShellLnk.tlb

Public Enum STGM
    STGM_DIRECT = &H0&
    STGM_TRANSACTED = &H10000
    STGM_SIMPLE = &H8000000
    STGM_READ = &H0&
    STGM_WRITE = &H1&
    STGM_READWRITE = &H2&
    STGM_SHARE_DENY_NONE = &H40&
    STGM_SHARE_DENY_READ = &H30&
    STGM_SHARE_DENY_WRITE = &H20&
    STGM_SHARE_EXCLUSIVE = &H10&
    STGM_PRIORITY = &H40000
    STGM_DELETEONRELEASE = &H4000000
    STGM_CREATE = &H1000&
    STGM_CONVERT = &H20000
    STGM_FAILIFTHERE = &H0&
    STGM_NOSCRATCH = &H100000
End Enum

' Shell Folder Path Constants
' on NT:          ..\WinNT\profiles\username
' on Windows 9x:  ..\Windows
Public Enum SHELLFOLDERS
    CSIDL_DISK_DIR = &HFF&          ' Special fudge value representing a disk directory
    CSIDL_DESKTOP = &H0&            ' \Desktop
    CSIDL_PROGRAMS = &H2&           ' \Start Menu\Programs
    CSIDL_CONTROLS = &H3&           ' No Path
    CSIDL_PRINTERS = &H4&           ' No Path
    CSIDL_PERSONAL = &H5&           ' \Personal
    CSIDL_FAVORITES = &H6&          ' \Favorites
    CSIDL_STARTUP = &H7&            ' \Start Menu\Programs\Startup
    CSIDL_RECENT = &H8&             ' \Recent
    CSIDL_SENDTO = &H9&             ' \SendTo
    CSIDL_BITBUCKET = &HA&          ' No Path
    CSIDL_STARTMENU = &HB&          ' \Start Menu
    CSIDL_DESKTOPDIRECTORY = &H10&  ' \Desktop
    CSIDL_DRIVES = &H11&            ' No Path
    CSIDL_NETWORK = &H12&           ' No Path
    CSIDL_NETHOOD = &H13&           ' \NetHood
    CSIDL_FONTS = &H14&             ' \fonts
    CSIDL_TEMPLATES = &H15&         ' \ShellNew
    CSIDL_COMMON_STARTMENU = &H16&  ' ..\WinNT\profiles\All Users\Start Menu
    CSIDL_COMMON_PROGRAMS = &H17&   ' ..\WinNT\profiles\All Users\Start Menu\Programs
    CSIDL_COMMON_STARTUP = &H18&    ' ..\WinNT\profiles\All Users\Start Menu\Programs\Startup
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19& '..\WinNT\profiles\All Users\Desktop
    CSIDL_APPDATA = &H1A&           ' ..\WinNT\profiles\username\Application Data
    CSIDL_PRINTHOOD = &H1B&         ' ..\WinNT\profiles\username\PrintHood
End Enum

Public Enum SHOWCMDFLAGS
    SHOWNORMAL = 5
    SHOWMAXIMIZE = 3
    SHOWMINIMIZE = 7
End Enum

Public Const MAX_PATH = 255

Declare Function SHGetSpecialFolderLocation Lib "Shell32" _
    (ByVal hwndOwner As Long, ByVal nFolder As Integer, _
    ppidl As Long) As Long
Declare Function SHGetPathFromIDList Lib "Shell32" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
    ByVal szPath As String) As Long
    
Public Function CreateShortcut(ShortcutType As SHELLFOLDERS, _
            ShowCmd As SHOWCMDFLAGS, _
            Optional sShortcutName As String, _
            Optional sIconFileName As String, _
            Optional sDBPath As String, _
            Optional sExeFileName As String, _
            Optional sWorkingDir As String, _
            Optional sWorkGroupFilePath As String, _
            Optional sIconDescription As String, _
            Optional sUserName As String, _
            Optional sPassword As String, _
            Optional bOpenExclusive As Boolean = False, _
            Optional bReadOnly As Boolean = False, _
            Optional bCompactOnClose As Boolean = False, _
            Optional bDisplayStartup As Boolean = False, _
            Optional bDecompile As Boolean = False) _
            As Long
    
    Dim cShellLink As ShellLinkA   ' An explorer IShellLinkA(Win 9x/Win NT) instance
    Dim cPersistFile As IPersistFile ' An explorer IPersistFile instance
    Dim lIconIndex As Long
    Dim sExeArgs As String
    
    On Error GoTo CreateShortcut_ErrorHandler
    
    'Setup shortcut parameters
    If (Len(sShortcutName) = 0) Then
        GoTo Exit_CreateShortcut
    Else
        If (ShortcutType = CSIDL_DISK_DIR) Then
            sShortcutName = ShortcutType & ".lnk"
        Else
            sShortcutName = GetSpecialPath(Application.hWndAccessApp, ShortcutType) & sShortcutName & ".lnk"
        End If
    End If
    
    lIconIndex = 0
    
    'Setup the command line arguments
    sExeFileName = IIf(Len(sExeFileName) = 0, """" & SysCmd(acSysCmdAccessDir) _
        & "msaccess.exe""", """" & sExeFileName & """")
    sExeArgs = IIf(Len(sDBPath) = 0, """" & CurrentDb.Name & """", """" & sDBPath & """")
    sExeArgs = sExeArgs & IIf(Len(sWorkGroupFilePath) = 0, "", " /wrkgrp """ & sWorkGroupFilePath & """")
    sExeArgs = sExeArgs & IIf(Len(sUserName) = 0, "", " /user """ & sUserName & """")
    sExeArgs = sExeArgs & IIf(Len(sPassword) = 0, "", " /pwd """ & sPassword & """")
    sExeArgs = sExeArgs & IIf(bOpenExclusive = False, "", " /excl")
    sExeArgs = sExeArgs & IIf(bReadOnly = False, "", " /ro")
    sExeArgs = sExeArgs & IIf(bCompactOnClose = False, "", " /compact")
    sExeArgs = sExeArgs & IIf(bDisplayStartup = False, "", " /nostartup")
    sExeArgs = sExeArgs & IIf(bDecompile = False, "", " /decompile")

    Set cShellLink = New ShellLinkA   'Create new IShellLink interface
    Set cPersistFile = cShellLink     'Implement cShellLink's IPersistFile interface
    
    With cShellLink
        'Debug.Print "sShortcutName " & sShortcutName
        'Set command line exe name & path to new shortcut.
        .SetPath sExeFileName
        'Debug.Print "sExeFileName " & sExeFileName
        'Set working directory in shortcut
        If Len(sWorkingDir) > 0 Then .SetWorkingDirectory sWorkingDir
        'Debug.Print "sWorkingDir " & sWorkingDir
        'Add arguments to command line
        If Len(sExeArgs) > 0 Then .SetArguments sExeArgs
        'Debug.Print "sExeArgs " & sExeArgs
        'Set shortcut description
        .SetDescription sIconDescription & vbNullChar
        'If (LnkDesc <> "") Then .SetDescription pszName
        'Set shortcut icon location & index
        If Len(sIconFileName) > 0 Then .SetIconLocation sIconFileName, lIconIndex
        'Debug.Print "sIconFileName " & sIconFileName
        'Set shortcut's startup mode (min,max,normal)
        .SetShowCmd ShowCmd
    End With
    
    cShellLink.Resolve 0, SLR_UPDATE
    cPersistFile.Save StrConv(sShortcutName, vbUnicode), 0 'Unicode conversion that must be done!
    CreateShortcut = True 'Return Success
    
Exit_CreateShortcut:
    Set cPersistFile = Nothing
    Set cShellLink = Nothing
    Exit Function
    
CreateShortcut_ErrorHandler:
    Resume Exit_CreateShortcut
End Function

Public Function GetSystemFolderPath(ByVal hwnd As Long, ByVal ID As Integer, _
    SystemFolderPath As String) As Long
    
    Dim lReturn As Long
    Dim lPidl   As Long
    Dim lPath   As Long
    Dim sPath   As String
    
    sPath = Space$(MAX_PATH)
    lReturn = SHGetSpecialFolderLocation(hwnd, ID, lPidl) 'Get lPidl for ID
    If lReturn = 0 Then ' If success is 0
        lReturn = SHGetPathFromIDList(lPidl, sPath) 'Get Path from Item Id List
        If lReturn = 1 Then 'If success is 1
            sPath = Trim$(sPath) 'Fix path string
            lPath = Len(sPath)   'Get length of path
            If Asc(Right$(sPath, 1)) = 0 Then lPath = lPath - 1      'Adjust path length
            If lPath > 0 Then SystemFolderPath = Left$(sPath, lPath) 'Adjust path string variable
            GetSystemFolderPath = True 'Return success
        End If
    End If
End Function

Public Function GetShellLinkInfo(sShortcutName As String, sExeFileName As String, _
    sWorkingDir As String, sExeArgs As String, sIconFileName As String, _
    lIconIndex As Long, lShowCmd As Long) As Long
    
    Dim lPidl        As Long              'Item id list
    Dim lHotKey      As Long              'Hotkey to shortcut...
    Dim lBuffLen     As Long
    Dim sTemp        As String
    Dim sDescription As String
    Dim cShellLink   As ShellLinkA        'An explorer IShellLink instance
    Dim cPersistFile As IPersistFile      'An explorer IPersistFile instance
    Dim fd           As WIN32_FIND_DATA
    
    If sShortcutName = "" Then Exit Function
    
    Set cShellLink = New ShellLinkA       'Create new IShellLink interface
    Set cPersistFile = cShellLink         'Implement cShellLink's IPersistFile interface
    
    'Load Shortcut file...(must do this UNICODE hack!)
    On Error GoTo GetShellLinkInfoError
    
    cPersistFile.Load StrConv(sShortcutName, vbUnicode), STGM_DIRECT
    
    With cShellLink
        'Get command line exe name & path to shortcut
        sExeFileName = Space$(MAX_PATH)
        lBuffLen = Len(sExeFileName)
        .GetPath sExeFileName, lBuffLen, fd, SLGP_UNCPRIORITY
        sTemp = fd.cFileName  ' Not returned to calling function
        
        'Get shortcut working directory
        sWorkingDir = Space$(MAX_PATH)
        lBuffLen = Len(sWorkingDir)
        .GetWorkingDirectory sWorkingDir, lBuffLen
        
        'Get shortcut command line arguments
        sExeArgs = Space$(MAX_PATH)
        lBuffLen = Len(sExeArgs)
        .GetArguments sExeArgs, lBuffLen
        
        'Get shortcut description
        sDescription = Space$(MAX_PATH)
        lBuffLen = Len(sDescription)
        .GetDescription sDescription, lBuffLen ' Not returned to calling function
        
        'Get shortcut HotKey
        .GetHotkey lHotKey  ' Not returned to calling function
       
        'Get shortcut icon location & index
        sIconFileName = Space$(MAX_PATH)
        lBuffLen = Len(sIconFileName)
        .GetIconLocation sIconFileName, lBuffLen, lIconIndex
        
        'Get Item ID List...
        .GetIDList lPidl ' Not returned to calling function
                
        'Set shortcut startup mode (Min/Max/Normal)
        .GetShowCmd lShowCmd
    End With
    
    GetShellLinkInfo = True
    
GetShellLinkInfoError:
    Set cPersistFile = Nothing
    Set cShellLink = Nothing
End Function

Public Function GetSpecialPath(hwnd As Long, ID As Long) As String
    Dim sPath As String
    Dim sSpecialPath As String
    
    If GetSystemFolderPath(hwnd, ID, sPath) Then
        'Call pSetDefaults(sPath)
        sSpecialPath = sPath
        If Right(sSpecialPath, 1) <> "\" Then sSpecialPath = sSpecialPath & "\"
    End If
    
    GetSpecialPath = sSpecialPath
End Function