Настройки - Модуль для работы с таблицей общих пользовательских настроек программы

Кода неоходимо задавать настройки ЕДИНЫЕ для всех пользователй, логично оформить их таблицей в общей базе.
Модуль пишет, читает, создает настройки в этой таблице.

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

' Module : modSettingsInTable

' Author : es

' Date : 20.10.2012

' Purpose : Модуль для работы с таблицей настроек программы (ОБЩИХ ДЛЯ ВСЕХ ПОЛЬЗОВАТЕЛЕЙ)

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

Option Compare Database

Option Explicit

'Константы ниже - используются по всему модулю, меняйте на своё усмотрение

Private Const sTableName As String = "dtSettings" 'Название таблицы для хранения настроек

Private Const sFieldName As String = "setName" 'Название поля названия настройки

Private Const sFieldNameLen As Integer = 150 'Длинна поля названия настройки

Private Const sFieldValName As String = "setVal" 'Название поля ЗНАЧЕНИЯ настройки

Private Const sFieldValNameLen As Integer = 255 'Длинна поля ЗНАЧЕНИЯ настройки

Public Function SettingGet(sName As String, Optional vDefVal As Variant = Null) As Variant

'Возвращает значение настройки

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

'Аргументы

' sName = Название настройки

' vDefVal = Значение по умолчанию (если нет настройки она будет добавлена)

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

Dim str As String

Dim rst As DAO.Recordset

On Error GoTo SettingGetErr

str = "SELECT " & sFieldValName & " FROM " & sTableName & " WHERE " & sFieldName & " = '" & sName & "'"

Set rst = CurrentDb.OpenRecordset(str, dbOpenSnapshot, dbReadOnly)

If rst.EOF = False Then

SettingGet = rst.Fields(sFieldValName)

Else

SettingAddNew sName, vDefVal

SettingGet = vDefVal

End If

SettingGetBye:

On Error Resume Next

rst.Close

Set rst = Nothing

Exit Function

SettingGetErr:

SettingGet = vDefVal

Err.Clear

Resume SettingGetBye

End Function

Public Sub esSetSetting(sName As String, sVal As Variant)

'Задаёт значение настройки

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

'Аргументы

' sName = Название настройки

' vVal = Значение (если нет настройки она будет добавлена)

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

Dim str As String

Dim rst As DAO.Recordset

Dim val As Variant

On Error GoTo esSetSettingErr

str = "SELECT " & sFieldValName & " FROM " & sTableName & " WHERE " & sFieldName & " = '" & sName & "'"

Set rst = CurrentDb.OpenRecordset(str, dbOpenDynaset)

If rst.EOF = False Then

rst.Edit

rst.Fields(sFieldValName) = sVal

rst.Update

Else

SettingAddNew sName, sVal

End If

SetSettingBye:

On Error Resume Next

rst.Close

Set rst = Nothing

Exit Sub

esSetSettingErr:

Err.Clear

Resume SetSettingBye

End Sub

Private Sub SettingAddNew(ByVal sName As String, ByVal vVal As Variant)

'Adds new setting

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

Dim rstAdd As DAO.Recordset

Dim str As String

On Error GoTo SettingAddNewErr

str = "SELECT * FROM " & sTableName

Set rstAdd = CurrentDb.OpenRecordset(str, dbOpenDynaset)

With rstAdd

.AddNew

.Fields(sFieldName) = sName

.Fields(sFieldValName) = vVal

.Update

End With

Exit Sub

SettingAddNewBye:

On Error Resume Next

rstAdd.Close

Set rstAdd = Nothing

SettingAddNewErr:

'Debug.Print "esSettingGet" & vbCrLf & Err.Description & vbCrLf & " Err#"; Err.Number

Err.Clear

Resume SettingAddNewBye

End Sub

Создать таблицу для хранения настроек можно так:

Private Sub CreateSettingTable()

' Однорацовая процедура: Создание таблицы настроек

' Использует Констаннты из заголовка модуля

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

Dim tbl As TableDef 'объект таблица

Dim idx As Index 'объект индекс

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

On Error GoTo CreateSettingTable_Err

Set tbl = CurrentDb.CreateTableDef(sTableName)

With tbl

.Fields.Append tbl.CreateField(sFieldName, dbText, sFieldNameLen)

.Fields.Append tbl.CreateField(sFieldValName, dbText, sFieldValNameLen)

'создание уникального индекса

Set idx = .CreateIndex("Primary Key")

With idx

'добавление поле "setName" в индекс

.Fields.Append .CreateField(sFieldName)

'Установка свойств индекса

.Unique = True 'Уникальный

.Primary = True 'Первичный

End With

.Indexes.Append idx

'индекс создан

End With

'Фактическое добавление таблицы из объектной переменной описанной выше

CurrentDb.TableDefs.Append tbl

CreateSettingTable_Bye:

On Error Resume Next

Set idx = Nothing

Set tbl = Nothing

Exit Sub

CreateSettingTable_Err:

MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _

"in procedure CreateSettingTable", vbCritical, "Error!"

Resume CreateSettingTable_Bye

End Sub