Окно приложения MS Access - Работа со свойствами (внешним видом)

Опубликовано 30.06.2022: https://www.cyberforum.ru/ms-access/thread3004362.html#post16331703

Использование
В модуль ЛЮБОЙ стартовой формы пишем что то вроде:

Private Sub Form_Load()
'Загрузка СТАРТОВОЙ формы
Dim s As String, sCap As String
Dim bShowHide As Boolean
    s = CurrentDb.Name 'Полный Путь к аппликации
'Проверяем расширение аппликации что не *.mde и не *.accde
    s = Right(s, 3)
    Select Case s
        Case "mde", "cde" 'Работает ПОЛЬЗОВАТЕЛЬ
            bShowHide = False 'Скрыть
            sCap = " (Работает ПОЛЬЗОВАТЕЛЬ)"
        Case Else         'Работает РАЗРАБОТЧИК
            bShowHide = True
            sCap = " (Работает РАЗРАБОТЧИК)"
    End Select

    SetAppOptions bShowHide
    Me.Caption = Me.Caption & sCap
End Sub

Я решил оформить ЭТО отдельным модулем, но можно разместить где угодно
Модуль:

'--------------------------------------------------------------------
' Module    : modAppProperties
' Author    : es
' Date      : 09.01.2013
' Purpose   : Работа со свойствами (внешним видом) приложения MS Access
'--------------------------------------------------------------------
Option Compare Database
Option Explicit


Public Sub SetAppOptions_And_Reload(strStartUpForm As String, strAppName As String, strIconFile As String)
'es - 09.01.2013
'  Заготовка под изменение всевозможных свойств текущей БД
'  Исполняем ЭТУ процедуру единожды для конкретной базы
'  ПОСЛЕ ВЫПОЛНЕНИЯ этой процедуры требуеться перегрузить базу
'АРГУМЕНТЫ:
'   strStartUpForm = Стартовая форма приложения
'   strAppName     = Заголовок Приложения
'   strIconFile    = Файл Иконки в папке приложения (без полн. пути)
'--------------------------------------------------------------------
Dim str As String
On Error GoTo SetAppOptions_And_Reload_Err

'01
'Иконка аппликации:
    str = CurrentProject.Path & "\" & strIconFile
    If Dir(str) <> "" Then 'Проверка физического наличия файла
        ChangeProperty "AppIcon", dbText, strIconFile
        Application.RefreshTitleBar
    End If

'02
'Заголовок
    ChangeProperty "AppTitle", dbText, strAppName
    Application.RefreshTitleBar
'03
'Назначаем форму запускаемую на старте приложения
    ChangeProperty "StartupForm", dbText, strStartUpForm
  
    'ChangeProperty "StartupMenuBar", dbText, "Главное меню"
    'ChangeProperty "AllowBuiltinToolbars", dbBoolean, False
    'ChangeProperty "AllowFullMenus", dbBoolean, False
    'ChangeProperty "AllowBreakIntoCode", dbBoolean, False

'--------------------------------------------------------------------
'ТУТ - Не трогаем (ПОКА), без особой надобности
    'ChangeProperty "AllowSpecialKeys", dbBoolean, False ' Спец комбинацци (F11, CTRL+BREAK, ...)
    'ChangeProperty "AllowBypassKey", dbBoolean, False   ' Запуск с шифтом [Shift]
'--------------------------------------------------------------------

'04
'Отменить отслеживание изменения имён вместе с их автокоррекцией
    ChangeProperty "Track name AutoCorrect info", dbBoolean, False
    'ChangeProperty "Perform name AutoCorrect", dbBoolean, False
    'ChangeProperty "Log name AutoCorrect changes", dbBoolean, False

'05
' Не показывать окно базы на старте = Display Navigation Pane
    ChangeProperty "StartUpShowDBWindow", dbBoolean, False

' Статус бар можно туда же ... НО! - если собираетесь его использовать - тогда оставьте
'    ChangeProperty "StartupShowStatusBar", dbBoolean, False

'06
'Отключаем окна в панели задач (свойство MSA 2003)
'    ChangeProperty "ShowWindowsInTaskbar", dbBoolean, False

'07
'Использовать перекрывающиеся окна (Overlapping Windows) = ON
    ChangeProperty "UseMDIMode", dbInteger, 1
'   Если СВОЙСТВО = Использовать перекрывающиеся окна (Overlapping Windows) = Off То:
'   ChangeProperty "ShowDocumentTabs", dbBoolean, True  'Табы документов


'08
'Использовать иконку приложения для Форм и Отчётов
    ChangeProperty "UseAppIconForFrmRpt", dbBoolean, True
    
'09 - Остальное
    With Application
    ' Статус бар
        '.SetOption "Show Status Bar", False
        '.SetOption "Show Startup dialog box", False
        '.SetOption "Show New object shortcuts", False
    'Поля отчётов
        '.SetOption "Left Margin", 0.5
        '.SetOption "Right Margin", 0.5
        '.SetOption "Top Margin", 1
        '.SetOption "Bottom Margin", 1
    
    'Только если установлены звуки MSO
        '.SetOption "Provide Feedback with sound", True
    
    'Отменить отслеживание изменения имён вместе с их автокоррекцией
        '.SetOption "Track name AutoCorrect info", False
        '.SetOption "Perform name AutoCorrect", False
        '.SetOption "Log name AutoCorrect changes", False
        '.SetOption "Default find/replace behavior", 1

        '.SetOption "Confirm Record changes", False
        '.SetOption "Confirm Document deletions", False
        '.SetOption "Confirm Action Queries", False
        '.SetOption "Show Values Limit", 1000 '= 1000 по умолч
        '.SetOption "Move after enter", False
        '.SetOption "Behavior entering field", 0
        '.SetOption "Arrow Key Behavior", 0
        '.SetOption "Cursor Stops At First/Last Field", True
        '.SetOption "Enable DDE Refresh", True
        '.SetOption "Refresh Interval (Sec)", 60
        '.SetOption "Default Open Mode for Databases", 1
        '.SetOption "Default Record Locking", 2
        '.SetOption "Use Row Level Locking", True
    End With

'10
'Дальше - Свойство CustomRibbonID = "StartUpRibbon"
'   если USysRibbons заполнена
'   ChangeProperty "CustomRibbonID", dbText, "StartUpRibbon"


'Перезагрузка базы
    If MsgBox("Изменения вступят в силу только после перезагрузки БАЗЫ ДАННЫХ!" & vbCrLf & _
        "Выйти из приложения?", vbInformation + vbOKCancel) = vbOK Then
        Application.Quit
    End If

SetAppOptions_And_Reload_Bye:
    Exit Sub

SetAppOptions_And_Reload_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure SetAppOptions_And_Reload", vbCritical, "Error!"
    Resume SetAppOptions_And_Reload_Bye

End Sub
 

Public Sub SetAppOptions(Optional bShow As Boolean = False)
' es - 09.01.2013
' Убирает или показывает на экране "Ненужности" в зависимости от параметра
' с учётом версии приложения
'--------------------------------------------------------------------
' АРГУМЕНТЫ:
'   bShow = Показать (True) или Скрыть элементы
'--------------------------------------------------------------------
Dim iAppVer As Integer
Dim iToolbarYesNo As Integer
'--------------------------------------------------------------------

On Error GoTo SetAppOptions_Err

'Версия MS Access
    iAppVer = CCur(Mid(Application.Version, 1, 2))

'--------------------------------------------------------------------
' Скрываем - показываем Toolbar-ы
'   Syntax:  DoCmd.ShowToolbar(ToolbarName, Show)
'   Где Show:
'       acToolbarNo (2)          Скрыть.
'       acToolbarWhereApprop (1) Display the toolbar while in the appropriate view.
'       acToolbarYes (0)         Показать.
'--------------------------------------------------------------------
    If bShow = False Then
        iToolbarYesNo = acToolbarNo  '=2 - Скрываем
    Else
        iToolbarYesNo = acToolbarYes '=0 - Отображаем
    End If
    
'Для версий MSA 2003 - 2007 и выше
    If iAppVer > 11 Then 'Версия MS Access 2007 и выше (не 2003)
    'Скрываем - Отображаем ленту "Ribbon"
        DoCmd.ShowToolbar "Ribbon", iToolbarYesNo

    Else 'Версия MS Access = 2003 или ниже

        'Скрываем тулбары
        CommandBars.Item("Menu Bar").Enabled = bShow
        DoCmd.ShowToolbar "Menu Bar", iToolbarYesNo
        DoCmd.ShowToolbar "Database", iToolbarYesNo
        DoCmd.ShowToolbar "Web", acToolbarNo 'или acToolbarWhereApprop
        'БАР печати можно и оставить ....
        'DoCmd.ShowToolbar "Formatting (Form/Report)", iToolbarYesNo
        DoCmd.ShowToolbar "Form View", iToolbarYesNo
    End If

'Строка состояния:
'   - Можно показать в любой момент: Application.SetOption "Show Status Bar", True
   Application.SetOption "Show Status Bar", bShow ' откл/вкл строку состояния

SetAppOptions_Bye:
    Exit Sub

SetAppOptions_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure SetAppOptions", vbCritical, "Error!"
    Resume SetAppOptions_Bye

End Sub


Private Function ChangeProperty(strPropName As String, iPropType As Integer, varPropValue As Variant) As Integer
'Просто замена свойства базы данных.
'Если заданное свойство отсутствует - функция создаст его
'--------------------------------------------------------------------
    Dim dbs As Database, prp As Property
    Const conPropNotFoundError = 3270
    Set dbs = CurrentDb

    If Len(varPropValue & "") = 0 Then
        On Error Resume Next
        dbs.Properties.Delete strPropName
        Err.Clear
        GoTo ChangeProperty_Bye
    End If
    
On Error GoTo ChangeProperty_Err
    dbs.Properties(strPropName) = varPropValue
    ChangeProperty = True

Change_Bye:
    Exit Function

Change_Err:
    If Err = conPropNotFoundError Then  ' Свойство не найдено.
        Set prp = dbs.CreateProperty(strPropName, iPropType, varPropValue)
        dbs.Properties.Append prp
        Resume Next
    Else
        ' Неизвестная ошибка.
        ChangeProperty = False
        Resume Change_Bye
    End If
End Function


Private Sub Print_In_Immediate_CurrentDB_Properties()
'es - 27.12.2012
'Вывод в Immediate Window списка всех свойств (Properties) теущей БД
'   Показать Immediate Window: [Ctrl + G]
'--------------------------------------------------------------------
Dim dbs As Database, prp As Property
Dim v As Variant
    Debug.Print "---------------------------------------------------"
    Set dbs = CurrentDb
    For Each prp In dbs.Properties
        v = Null
        On Error Resume Next
        v = prp.Value
        Err.Clear
        Debug.Print prp.Name & " = " & v
    Next
    Debug.Print "---------------------------------------------------"
    Set prp = Nothing
    Set dbs = Nothing
End Sub

В примере кнопка:
"Задать Базовые Параметры (+ Перегруз Базы)"
Выполняет следующий код:

Const strStartUpForm As String = "00OnStart"
'Имя аппликации:
Const strAppName As String = "Пример v001"
Const strIconFile As String = "Application.ico"
'Устанавливаем:
    SetAppOptions_And_Reload strStartUpForm, strAppName, strIconFile

После перезапуска базы увидим:
    - Появилась Иконка и Заголовок
    - Экран за формой чист ...

Поле нажатия на кнопку: "Показать Ненужное"

То же самое под MSA 2010:

Кстати:
Windows 7 (и выше) - отображают в панели задач не заданную иконку аппликации, а иконку  MS Access

Вот простейшее решение:
01. Создаём ярлык на аппликацию:
02. В поле "Объект" вместо:
    "D:\Temp\AppProperties MSA2003\AppProperties MSA2003 v001.mdb"
    Пишем всё вмете (с путём к MSACCESS.EXE) типа:
    "C:\Program Files\Microsoft Office\Office14\MSACCESS.EXE" "D:\Temp\AppProperties MSA2003\AppProperties MSA2003 v001.mdb"
03. У Ярлыка задаём иконку какую надо.
04. Сохраняем и запускаем...
Иконка будет заданной.

На рисунке, обе иконки = аппликации MS Access

MSA-2007 ( 411 kB) Пример