Создание ярлыка на текущее приложение с ключами /decompile /compact (в папке приложения)

'--------------------------------------------------------------------------
' Module    : modCreateShortcut
' Author    : es
' Date      : 30.08.2017
' Purpose   : Создание ярлыков произвольного назначения
'--------------------------------------------------------------------------
Option Compare Database
Option Explicit
Private Sub CreateDecompile_and_Compact_Shortcut()
'Создание ярлыка на текущее приложение с ключами  /decompile /compact
'--------------------------------------------------------------------------
Dim sAppIconPathNo As String     ' Полный путь к иконке с номером через запчтую
Dim iWindowStyle As Integer      ' Тип запускаемого окна
Dim sMSAccessPath$, sMSAccessFolder$, sPathToRunFile$
Dim s$
Dim sLNKPath$
'Удаление старых компактеров
    s = CurrentProject.path & "\* - Decompile*.lnk"
    If Dir(s) <> "" Then Kill (s) ' Deletion!
    
    s = CurrentProject.path & "\* - Compact*.lnk"
    If Dir(s) <> "" Then Kill (s) ' Deletion!
    
'------------------------------------------------------------------------------------
    sLNKPath = CurrentDb.Name & " - Decompile and Compact.lnk"
    sMSAccessPath = SysCmd(acSysCmdAccessDir) & "msaccess.exe"
    sMSAccessFolder = FolderByPath(sMSAccessPath) 'папка
    iWindowStyle = 7 ' 7 = Minimizes the window and activates the next top-level window.
    sPathToRunFile = """" & CurrentProject.path & "\" & CurrentProject.Name & """"
    'Debug.Print sPathToRunFile
    sAppIconPathNo = sMSAccessPath & ",0"

'Создание ярлыка:

    CreateShortcut sLNKPath, sMSAccessPath, sMSAccessFolder, sAppIconPathNo, , sPathToRunFile & " /decompile /compact", , iWindowStyle
    
    sLNKPath = CurrentDb.Name & " - Decompile Only.lnk"
    CreateShortcut sLNKPath, sMSAccessPath, sMSAccessFolder, sAppIconPathNo, , sPathToRunFile & " /decompile", , iWindowStyle

    sLNKPath = CurrentDb.Name & " - Compact Only.lnk"
    CreateShortcut sLNKPath, sMSAccessPath, sMSAccessFolder, sAppIconPathNo, , sPathToRunFile & " /compact", , iWindowStyle



 End Sub


Private Sub CreateShortcut(ByRef ShortcutPath As String, ByRef STargetCommand As String, _
                          ByRef SWorkingDirectory As String, Optional ByRef SHIconPath As String = "", _
                          Optional ByRef HotKey As String = "", Optional ByRef SArguments As String = "", _
                          Optional ByRef SHDescription As String = "", Optional ByRef WindowStyle As Integer = vbNormalFocus)

'Поматериалам: http://www.vbnet.ru/forum/show.aspx?id=15163
'-------------------------------------------------------------------------------------
'Аргументы:
'   WindowStyle = vbMaximizedFocus = 3
'   WindowStyle
'       1: Activates and displays a window. If the window is minimized or maximized, the system restores it to its original size and position.
'       3: Activates the window and displays it as a maximized window.
'       7: Minimizes the window and activates the next top-level window.
'-------------------------------------------------------------------------------------
Dim WshShell As Object
Dim oShellLink As Object
Dim sLinkPath As String
    
    Set WshShell = CreateObject("WScript.Shell")
    '-------------------------------------------------------------------------------------
    On Error GoTo 0
    Set oShellLink = WshShell.CreateShortcut(ShortcutPath) '(SCPath & SCName & ".lnk")
    With oShellLink
        .TargetPath = STargetCommand        'Полный путь = Обьект
        .Arguments = SArguments
        '.TargetPath = oShellLink.TargetPath & " " & SPar
        .WorkingDirectory = SWorkingDirectory

        .IconLocation = SHIconPath 'calc.exe,0
        .HotKey = HotKey
        .WindowStyle = WindowStyle
        .Description = SHDescription
        .Save
    End With
    Set oShellLink = Nothing
    Set WshShell = Nothing

End Sub


Public Function FolderByPath(varPath As Variant, Optional bolRetNoSlash As Boolean = False) As String
'es 10.07.2012 : LE 15.02.2019
'Возвращает путь к папке по указанному в аргументе полному пути к файлу.
'--------------------------------------------------------------------
'   По умолчанию Возвращаемая строка содержит слеш в конце "C:\Temp\"
'   При ошибке возвращает корень диска "C:\"
'--------------------------------------------------------------------

On Error GoTo FolderByPath_Err
    'Рубим путь до последнего левого слеша ("\")
    FolderByPath = Mid(varPath, 1, InStrRev(varPath, "\"))
    'Debug.Print FolderByPath

'На всякий случай - проверка существования пути (не обязательно)
    If Dir(FolderByPath, vbDirectory) = "" Then FolderByPath = "C:"
    'Debug.Print FolderByPath

'Без слеша ... если задано (пока с ним)
    If bolRetNoSlash = True Then
        If Right(FolderByPath, 1) = "\" Then
            FolderByPath = Mid(FolderByPath, 1, Len(FolderByPath) - 1)
        End If
    End If

FolderByPath_Bye:
    Exit Function

FolderByPath_Err:
    If bolRetNoSlash = False Then
        FolderByPath = "C:\"
    Else
        FolderByPath = "C:"
    End If
    Resume FolderByPath_Bye
End Function