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

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

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

'--------------------------------------------------------------------
' Module    : modSettingsInTable (название модуля не суть важно)
' Author    : es
' Date      : 20.10.2012 - 19.11.2018 (LE)
' Purpose   : Модуль для работы с таблицей общих (для всех пользователей) настроек приложения (DAO)
'--------------------------------------------------------------------

'Константы ниже - используются по всему модулю, меняйте на своё усмотрение
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 GetSetting(sName As String, Optional vDefVal As Variant = Null) As Variant
'Возвращает значение настройки
'--------------------------------------------------------------------
'Аргументы
'   sName    = Название настройки
'   vDefVal  = Значение по умолчанию (работает только если настройка не существует)
' - если нет настройки она будет добавлена со значением по умолчанию
'--------------------------------------------------------------------
Dim str As String
Dim rst As DAO.Recordset
On Error GoTo GetSettingErr
    
    str = "SELECT " & sFieldValName & " FROM " & sTableName & " WHERE " & sFieldName & " = '" & sName & "'"
    Set rst = CurrentDb.OpenRecordset(str, dbOpenSnapshot, dbReadOnly)
    
    If rst.EOF = False Then
        GetSetting = rst.Fields(sFieldValName)
    Else
        SettingAddNew sName, vDefVal
        GetSetting = vDefVal
    End If

    If IsNull(GetSetting) Then GetSetting = vDefVal

GetSettingBye:
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    Exit Function

GetSettingErr:
    GetSetting = vDefVal
    Err.Clear
    Resume GetSettingBye
End Function


Public Sub SetSetting(sName As String, vVal As Variant)
'Задаёт новое значение настройки
'--------------------------------------------------------------------
'Аргументы
'   sName    = Название настройки
'   vVal     = Значение (если нет настройки она будет добавлена)
' - если нет настройки она будет добавлена со значением vVal
'--------------------------------------------------------------------
Dim str As String
Dim rst As DAO.Recordset
On Error GoTo SetSettingErr
    str = "SELECT " & sFieldValName & " FROM " & sTableName & " WHERE " & sFieldName & " = '" & sName & "'"
    Set rst = CurrentDb.OpenRecordset(str, dbOpenDynaset)
    If rst.EOF = False Then
        rst.Edit
        rst.Fields(sFieldValName) = vVal
        rst.Update
    Else
        SettingAddNew sName, vVal
    End If
    
SetSettingBye:
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    Exit Sub

SetSettingErr:
    Err.Clear
    Resume SetSettingBye
End Sub


Private Sub SettingAddNew(sName As String, vVal As Variant)
'Добавление новой настройки
'--------------------------------------------------------------------
'Аргументы
'   sName    = Название настройки
'   vVal     = Значение настройки
'--------------------------------------------------------------------
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 "GetSetting" & 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


Назад ToTop
L.E. 04.11.2021
Рейтинг@Mail.ru