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

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

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

' Не показывать окно базы на старте

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, varPropType As Variant, varPropValue As Variant) As Integer

'Просто замена свойства базы данных.

'Если заданное свойство отсутствует - функция создаст его

'--------------------------------------------------------------------

Dim dbs As Database, prp As Property

Const conPropNotFoundError = 3270

Set dbs = CurrentDb

On Error GoTo Change_Err

dbs.Properties(strPropName) = varPropValue

ChangeProperty = True

Change_Bye:

Exit Function

Change_Err:

If Err = conPropNotFoundError Then ' Свойство не найдено.

Set prp = dbs.CreateProperty(strPropName, varPropType, 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

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

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

' Не показывать окно базы на старте

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, varPropType As Variant, varPropValue As Variant) As Integer

'Просто замена свойства базы данных.

'Если заданное свойство отсутствует - функция создаст его

'--------------------------------------------------------------------

Dim dbs As Database, prp As Property

Const conPropNotFoundError = 3270

Set dbs = CurrentDb

On Error GoTo Change_Err

dbs.Properties(strPropName) = varPropValue

ChangeProperty = True

Change_Bye:

Exit Function

Change_Err:

If Err = conPropNotFoundError Then ' Свойство не найдено.

Set prp = dbs.CreateProperty(strPropName, varPropType, 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-2000 ( 415 kB) Пример