Триггер

\r\nPublic Function TriggerB( _\r\n        ByVal decID As Variant, _\r\n        ByVal bytAct As Byte, _\r\n        ByVal strTabName As String, _\r\n        ByVal strFildID As String, _\r\n        ByVal strFildDel As String _\r\n        ) As Boolean                \' логирование вносимых изменений в данные\r\n    \' автор: Бенедикт, sgobunkov@yandex.ru\r\n    \' источник: /topic/545973&hl=%f2%f0%e8%e3%e3%e5%f0\r\n    \' связанные ресурсы:\r\n    \' /topic/545973&pg=-1\r\n    \' /topic/145122&pg=-1&hl=%f2%f0%e8%e3%e3%e5%f0%20%e1%e5%ed%e5%e4%e8%ea%f2%e0\r\n    Dim bytActOld As Byte               \' действие выполненное над текущей записью ранее\r\n    Dim bytErrCount As Byte             \' число ошибок тригера\r\n    Dim decCurrentCenter As Variant     \' ИД текущего центра учёта\r\n    Dim decTabName As Variant           \' ИД таблицы, в которую вносятся изменения\r\n    Dim rstSincRemote As DAO.Recordset  \' набор записей текущего отчёта\r\n    \r\n    On Error GoTo ErrorHandle\r\n    \' получаем ИД текущего центра учёта\r\n    decCurrentCenter = Application.DLookup("SincCntrID", "tblSincCenter", "(((SincCntrCurrent)=" & True & "))")\r\n    \' получаем ИД таблицы для отчёта\r\n    decTabName = Application.DLookup("SincTblID", "tblSincTabels", "(((SincTblName)=" & Chr(34) & strTabName & Chr(34) & "))")\r\n    \r\n    \' получаем набор записей отчёта, относящихся к текущей базе данных\r\n    Set rstSincRemote = CurrentDb.OpenRecordset( _\r\n                        " SELECT tblSincRemote.* " _\r\n                        & " FROM tblSincRemote " _\r\n                        & " WHERE (((tblSincRemote.SincRmtCentr)=" & decCurrentCenter & "));")\r\n    With rstSincRemote\r\n        \' ищем в отчёте требуемую запись\r\n        .FindFirst "((SincRmtTable=" & decTabName & ") AND (SincRmtRowID=" & decID & "))"\r\n        If .NoMatch Then\r\n            If bytAct = 0 Then bytAct = CByte(50)\r\n            .AddNew\r\n            .Fields("SincRmtCentr") = decCurrentCenter\r\n            .Fields("SincRmtTable") = decTabName\r\n            .Fields("SincRmtRowID") = decID\r\n            .Fields("SincRmtAct") = bytAct\r\n            .Update\r\n        Else\r\n            bytActOld = Application.DLookup(strFildDel, strTabName, "(((" & strFildID & ")=" & decID & "))")\r\n            If (bytActOld <> 10 Or bytActOld <> 50) And (bytAct <> 10 Or bytAct <> 20) Then\r\n            \' пропускаем из обработки изменяемые записи, которые добавили, но не синхронизировали\r\n                .Edit\r\n                .Fields("SincRmtAct") = bytAct\r\n                .Update\r\n            End If\r\n        End If\r\n        .Close\r\n    End With\r\n    \r\n    Set rstSincRemote = Nothing\r\n    TriggerB = True\r\n    Exit Function\r\n\r\nErrorHandle:\r\n    Select Case Err.Number\r\n        Case Is = 3008, 3078\r\n            \' 3008 - Случается при установке "триггера" запросом CreateTrigger\r\n            \' 3078 - Случается при синхронизации\r\n            On Error Resume Next\r\n        Case Else\r\n            MsgBox "Trigger-error (" & Err.Number & "): " & vbCr & Err.Description, , "Сработка триггера"\r\n            Err.Clear\r\n            If bytErrCount < 5 Then\r\n                \' если ошибок меньше пяти, то продолжаем с места ошибки\r\n                bytErrCount = bytErrCount + 1\r\n                Resume\r\n            Else\r\n                MsgBox "Привышен лимит ошибок тригера.", , "Сработка триггера"\r\n                On Error GoTo 0\r\n            End If\r\n    End Select\r\n    If Not rstSincRemote Is Nothing Then rstSincRemote.Close\r\n    Set rstSincRemote = Nothing\r\n    TriggerB = True\r\nEnd Function\r\n

\r\nOption Compare Database\r\nOption Explicit\r\n\r\nPrivate Sub cboTables_AfterUpdate()\r\n    Dim f As Integer\r\n    Dim strFildName As String\r\n    Dim strTabName As String\r\n    \r\n    strTabName = cboTables.Value\r\n    With Me.cboFildId\r\n        .RowSourceType = "Value List"\r\n        .RowSource = ""\r\n        .DefaultValue = ""\r\n    End With\r\n    With Me.cboFildAct\r\n        .RowSourceType = "Value List"\r\n        .RowSource = ""\r\n        .DefaultValue = ""\r\n    End With\r\n    For f = 0 To CurrentDb.TableDefs(strTabName).Fields.Count - 1\r\n        strFildName = CurrentDb.TableDefs(strTabName).Fields(f).Name\r\n        cboFildId.AddItem strFildName\r\n        cboFildAct.AddItem strFildName\r\n        \'If LCase(Right(strFildName, 2)) = "id" Then Me.cboFildId.DefaultValue = strFildName\r\n    Next f\r\nEnd Sub\r\n\r\nPrivate Sub cmdGetNames_Click()\r\n    Dim td As TableDef\r\n    Dim strTabName As String\r\n    \r\n    With cboFildId\r\n        .RowSourceType = "Value List"\r\n        .RowSource = ""\r\n        .DefaultValue = ""\r\n    End With\r\n    With cboFildAct\r\n        .RowSourceType = "Value List"\r\n        .RowSource = ""\r\n        .DefaultValue = ""\r\n    End With\r\n    With Me.cboTables\r\n        .RowSourceType = "Value List"\r\n        .RowSource = ""\r\n        .DefaultValue = ""\r\n    End With\r\n    For Each td In CurrentDb.TableDefs\r\n        strTabName = td.Name\r\n        If Left(strTabName, 4) <> "MSys" And Left(strTabName, 4) <> "USys" Then Me.cboTables.AddItem strTabName\r\n    Next td\r\nEnd Sub\r\n\r\nPrivate Sub cmdTriggerDrop_Click()\r\n    Dim strSQL As String\r\n    Dim strTabName As String\r\n    \r\n    On Error Resume Next\r\n    strTabName = Me.cboTables\r\n    strSQL = "ALTER TABLE " & strTabName & " DROP CONSTRAINT Trigger_" & strTabName & ";"\r\n    CurrentProject.Connection.Execute strSQL\r\n    If Err.Number <> 0 Then\r\n        MsgBox Err.Number & ": " & Err.Description, , "Удаление триггера"\r\n        Err.Clear\r\n    Else\r\n        MsgBox "Триггер отменён.", , "Удаление триггера"\r\n    End If\r\nEnd Sub\r\n\r\nPrivate Sub cmdTriggerSet_Click()\r\n    Dim strSQL As String\r\n    Dim strTabName As String\r\n    Dim strFildID As String\r\n    Dim strFildAct As String\r\n    \r\n    If IsNull(cboTables) Or IsNull(cboFildId) Or IsNull(cboFildAct) Then\r\n        MsgBox "Не возможно установить триггер. Вы указали не полные данные.", vbCritical\r\n        Exit Sub\r\n    End If\r\n    strTabName = Me.cboTables\r\n    strFildID = Me.cboFildId\r\n    strFildAct = Me.cboFildAct\r\n    If strTabName = "" Or strFildID = "" Or strFildAct = "" Then\r\n        MsgBox "Не возможно установить триггер. Вы указали не полные данные.", vbCritical\r\n        Exit Sub\r\n    End If\r\n    On Error Resume Next\r\n    strSQL = "ALTER TABLE " & strTabName & " ADD CONSTRAINT Trigger_" & strTabName & " " _\r\n            & "CHECK ((SELECT TriggerB(" & strTabName & "." & strFildID & ", " _\r\n                                        & strTabName & "." & strFildAct & ", " _\r\n                                        & """" & strTabName & """, " _\r\n                                        & """" & strFildID & """, " _\r\n                                        & """" & strFildAct & """) FROM MSysObjects WHERE Id=2));"\r\n    CurrentProject.Connection.Execute strSQL\r\n    If Err.Number <> 0 Then\r\n        MsgBox Err.Number & ": " & Err.Description, , "Установка триггера"\r\n        Err.Clear\r\n    Else\r\n        MsgBox "Триггер установлен.", , "Установка триггера"\r\n    End If\r\nEnd Sub\r\n\r\nPrivate Sub Form_Close()\r\n    With cboFildId\r\n        .RowSource = ""\r\n        .DefaultValue = ""\r\n    End With\r\n    With cboFildAct\r\n        .RowSource = ""\r\n        .DefaultValue = ""\r\n    End With\r\n    With cboTables\r\n        .RowSource = ""\r\n        .DefaultValue = ""\r\n    End With\r\nEnd Sub\r\n

\r\nOption Compare Database\r\nOption Explicit\r\n\r\nPublic decCenterTrigger As Variant  \' ИД центра учёта\r\n\r\nPublic Function TriggerB( _\r\n        ByVal decID As Variant, _\r\n        ByVal bytAct As Byte, _\r\n        ByVal strTabName As String, _\r\n        ByVal strFildID As String, _\r\n        ByVal strFildDel As String _\r\n        ) As Boolean                \' логирование вносимых изменений в данные\r\n    \' автор: Бенедикт, sgobunkov@yandex.ru\r\n    \' источник: /topic/545973&hl=%f2%f0%e8%e3%e3%e5%f0\r\n    \' связанные ресурсы:\r\n    \' /topic/545973&pg=-1\r\n    \' /topic/145122&pg=-1&hl=%f2%f0%e8%e3%e3%e5%f0%20%e1%e5%ed%e5%e4%e8%ea%f2%e0\r\n    \r\n    \'------------------\r\n    \' "СЕРВЕРНАЯ" ВЕРСИЯ\r\n    \'------------------\r\n    Dim bytActOld As Byte               \' действие выполненное над текущей записью ранее\r\n    Dim bytErrCount As Byte             \' число ошибок тригера\r\n    Dim Cnxn As ADODB.Connection        \' связь\r\n    Dim decCenterID As Variant          \' ИД текущего центра учёта\r\n    Dim decTabName As Variant           \' ИД таблицы, в которую вносятся изменения\r\n    Dim rstRemote As ADODB.Recordset    \' набор записей текущего отчёта\r\n    \r\n    \'On Error GoTo ErrorHandle\r\n    \' получаем ИД текущего центра учёта\r\n    decCenterID = decCenterTrigger\r\n    \' подключаемся к базе\r\n    Set Cnxn = ConnectOpenB(decCenterID)\r\n    \' получаем ИД таблицы для отчёта\r\n    decTabName = TableIdF(Cnxn, strTabName)\r\n    \r\n    \' получаем набор записей отчёта, относящихся к текущей базе данных\r\n    Set rstRemote = RecordsetOpen(Cnxn, "SELECT tblSincRemote.* " _\r\n                                        & "FROM tblSincRemote " _\r\n                                        & "WHERE (((tblSincRemote.SincRmtCentr)=" & decCenterID & ") " _\r\n                                                    & "AND ((tblSincRemote.SincRmtTable)=" & decTabName & "));" _\r\n                                    , adOpenKeyset, adLockOptimistic)\r\n    With rstRemote\r\n        \' ищем в отчёте требуемую запись\r\n        .Find "(((SincRmtRowID)=" & decID & "))"\r\n        If .EOF Then\r\n            If bytAct = 0 Then bytAct = CByte(50)\r\n            .AddNew\r\n            .Fields("SincRmtCentr") = decCenterID\r\n            .Fields("SincRmtTable") = decTabName\r\n            .Fields("SincRmtRowID") = decID\r\n            .Fields("SincRmtAct") = bytAct\r\n            .Update\r\n        Else\r\n            bytActOld = GetFirstRecordF(Cnxn, strFildDel, strTabName, "(((" & strFildID & ")=" & decID & "))")\r\n            If (bytActOld <> 10 Or bytActOld <> 50) And (bytAct <> 10 Or bytAct <> 20) Then\r\n            \' пропускаем из обработки изменяемые записи, которые добавили, но не синхронизировали\r\n                .Fields("SincRmtAct") = bytAct\r\n                .Update\r\n            End If\r\n        End If\r\n        .Close\r\n    End With\r\n    \r\n    Set rstRemote = Nothing\r\n    Cnxn.Close\r\n    Set Cnxn = Nothing\r\n    TriggerB = True\r\n    Exit Function\r\n\r\nErrorHandle:\r\n    Select Case Err.Number\r\n        Case Is = 3008, 3078\r\n            \' 3008 - Случается при установке "триггера" запросом CreateTrigger\r\n            \' 3078 - Случается при синхронизации\r\n            On Error Resume Next\r\n        Case Else\r\n            MsgBox "Trigger-error (" & Err.Number & "): " & vbCr & Err.Description, , "Сработка триггера с ошибкой"\r\n            Err.Clear\r\n            If bytErrCount < 5 Then\r\n                \' если ошибок меньше пяти, то продолжаем с места ошибки\r\n                bytErrCount = bytErrCount + 1\r\n                Resume\r\n            Else\r\n                MsgBox "Привышен лимит ошибок тригера.", , "Сработка триггера с ошибкой"\r\n                On Error GoTo 0\r\n            End If\r\n    End Select\r\n    Call RecordsetClose(rstRemote, "TriggerB - central")\r\n    Call ConnectClose(Cnxn, "TriggerB - central")\r\n    TriggerB = True\r\nEnd Function\r\n

\r\n    \' отмечаем ИД центра обработки для триггера\r\n    decCenterTrigger = decCenterTo\r\n    \' обновляем реципиента\r\n    rstTo.Update\r\n    \' отмечаем ИД центра обработки для триггера\r\n    decCenterTrigger = decCenterFrom\r\n    \' обновляем источник\r\n    If blnUpdateFrom Then .Update\r\n    decCenterTrigger = 0\r\n