|
|
Настройки - Модуль для работы с таблицей общих пользовательских настроек программы
Кода неоходимо задавать настройки ЕДИНЫЕ для всех пользователй, логично оформить их таблицей в общей базе.
Модуль пишет, читает, создает настройки в этой таблице.
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
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)
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)
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:
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
.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
|
|