VBA, MS Access MS Access в примерах

Создание ярлыка на текущее приложение с ключами /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


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

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

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

FolderByPath_Bye:
    If bolRetWithSlash = True Then FolderByPath = FolderByPath & "\"
    Exit Function

FolderByPath_Err:
    FolderByPath = "C:"
    
    Resume FolderByPath_Bye
End Function
Назад ToTop
L.E. 16.10.2018
Рейтинг@Mail.ru