TopPicLogo TopPicText

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

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

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

Option Compare Database
Option Explicit

'Константы ниже - используются по всему модулю, меняйте на своё усмотрение
Private Const sTableName As String = "dtSetting"       'Название таблицы для хранения настроек
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
Назад ToTop
L.E. 19.01.2013
Рейтинг@Mail.ru