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

Не связанная форма - Отправка данных в таблицу с реализацией "механизма транзакции"

По материалам: https://www.cyberforum.ru/ms-access/thread3115148.html

Часть кода из примера:

Private Sub cmdAction_Click()
' Нажатие на кнопку "Применить!"
' -------------------------------------------------------------------------------------------------/
Dim rst As DAO.Recordset
On Error GoTo cmdAction_Click_Err

' Проверка введённого:
    If Me.ComboТип.ListIndex = -1 Then
        MsgBox "Тип указан не верно!", vbExclamation, "Ошибка"
        Me.ComboТип.SetFocus
        Exit Sub
    End If
    
    If Not Nz(Me.TextСумма, 0) > 0 Then
        MsgBox "Сумма указана не верно!", vbExclamation, "Ошибка"
        Me.TextСумма.SetFocus
        Exit Sub
    End If

' Me.ComboТип.RowSource = "-1;Списание;0;Перевод;1;Поступление"
    Select Case Me.ComboТип
        Case -1    '-1; Списание
            If Me.ComboОтправитель.ListIndex = -1 Then
                MsgBox "Отправитель не указан!", vbExclamation, "Ошибка"
                Me.ComboОтправитель.SetFocus
                Me.ComboОтправитель.Dropdown
                Exit Sub
            End If
            
            If Me.TextСумма > CCur(Nz(Me.TextБалансОтправитель, 0)) Then
                MsgBox "Сумма превышает остаток!", vbExclamation, "Ошибка"
                Me.TextСумма = CCur(Nz(Me.TextБалансОтправитель, 0))
                Me.TextСумма.SetFocus
            End If
            
        Case 0     '0;  Перевод
            If Me.ComboОтправитель.ListIndex = -1 Then
                MsgBox "Отправитель не указан!", vbExclamation, "Ошибка"
                Me.ComboОтправитель.SetFocus
                Me.ComboОтправитель.Dropdown
                Exit Sub
            End If
            
            If Me.TextСумма > CCur(Nz(Me.TextБалансОтправитель, 0)) Then
                MsgBox "Сумма превышает остаток!", vbExclamation, "Ошибка"
                Me.TextСумма = CCur(Nz(Me.TextБалансОтправитель, 0))
                Me.TextСумма.SetFocus
            End If
            
            If Me.ComboПолучатель.ListIndex = -1 Then
                MsgBox "Получатель не указан!", vbExclamation, "Ошибка"
                Me.ComboПолучатель.SetFocus
                Me.ComboПолучатель.Dropdown
                Exit Sub
            End If
            
            If Me.ComboОтправитель = Me.ComboПолучатель Then
                MsgBox "Отправитель и Получатель совпадают!", vbExclamation, "Ошибка"
                Me.ComboПолучатель.SetFocus
                Exit Sub
            End If

        Case 1   ' 1; Поступление
            If Me.ComboПолучатель.ListIndex = -1 Then
                MsgBox "Получатель не указан!", vbExclamation, "Ошибка"
                Me.ComboПолучатель.SetFocus
                Me.ComboПолучатель.Dropdown
                Exit Sub
            End If
        Case Else
    End Select

' -------------------------------------------------------------------------------------------------/
'Дальше:
    Set rst = CurrentDb.OpenRecordset("Транзакции")   'Открытие на редакцию
    With rst
        .AddNew
            !Тип = Me.ComboТип
            !ОтправительSID = Nz(Me.ComboОтправитель, 0)
            !ПолучательSID = Nz(Me.ComboПолучатель, 0)
            !Сумма = Me.TextСумма
            !Назначение = Me.TextНазначение
        .Update
    End With
    rst.Close
    Set rst = Nothing

    Call RecountAll
    ComboОтправитель_AfterUpdate
    ComboПолучатель_AfterUpdate
    Me.TextСумма = 0
    Me.TextСумма.SetFocus
    
    MsgBox "Операция успешно завершена.", vbInformation, "Ура-а-а-а!"
    


' -------------------------------------------------------------------------------------------------/
cmdAction_Click_End:
    On Error Resume Next
    Err.Clear
    Exit Sub
' -------------------------------------------------------------------------------------------------/
cmdAction_Click_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub :" & _
        "cmdAction_Click - Form_Транзакция.", vbCritical, "Error!"
    'Debug.Print "cmdAction_Click_Line: " & Erl & "."
    Err.Clear
    Resume cmdAction_Click_End

End Sub
Private Sub RecountAll() 'Полный пересчёт!
Dim sSQL$
    sSQL = "UPDATE Клиенты SET Клиенты.Баланс = 0;"
    CurrentDb.Execute sSQL
    
    sSQL = "UPDATE Клиенты INNER JOIN Транзакции ON Клиенты.КлиентID = Транзакции.ПолучательSID SET Баланс = [Баланс]+[Сумма];"
    CurrentDb.Execute sSQL
    
    sSQL = "UPDATE Клиенты INNER JOIN Транзакции ON Клиенты.КлиентID = Транзакции.ОтправительSID SET Баланс = [Баланс]-[Сумма];"
    CurrentDb.Execute sSQL
   
End Sub


Picture




Скачать

MSA-2007 и выше ( 63 kB) Пример


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