Skip to main content

Кнопки навигации на форме

Стандартный модуль mFormRecordButtons

Создай обычный стандартный модуль:

Создание → Модуль

Имя модуля:

mFormRecordButtons

И вставь туда код:

Option Compare Database
Option Explicit

' ============================================================
' УНИВЕРСАЛЬНЫЙ МОДУЛЬ УПРАВЛЕНИЯ ЗАПИСЯМИ ФОРМЫ
'
' Назначение:
'   Универсальные процедуры для кнопок:
'
'       - Сохранить
'       - Создать
'       - Удалить
'       - Далее
'       - Назад
'       - переход на последнюю существующую запись
'       - счетчик записей вида "5 из 35"
'
' Основные ограничения, которые учитываются:
'
'   1. Кнопка "Далее" НЕ переходит на пустую новую запись.
'      Если текущая запись последняя — форма остается на последней записи.
'
'   2. Кнопка "Назад" НЕ вызывает ошибку на первой записи.
'      Если текущая запись первая — форма остается на первой записи.
'
'   3. При удалении первой записи форма корректно переходит
'      на новую первую запись.
'
'   4. При удалении последней записи форма корректно переходит
'      на новую последнюю запись.
'
'   5. При удалении единственной записи форма остается без записей,
'      без ошибки перехода.
'
'   6. Во время служебных операций используется флаг
'      gFormRecordOperationBusy, чтобы Form_Current не обновлял
'      счетчик в промежуточном состоянии формы.
'
' Пример использования в форме:
'
'   Call SaveCurrentFormRecord(Me)
'   Call CreateNewFormRecord(Me)
'   Call DeleteCurrentFormRecord(Me)
'   Call MoveToNextExistingRecord(Me)
'   Call MoveToPreviousExistingRecord(Me)
'   Call GoToLastExistingRecord(Me)
'
'   Me.Нумерация = GetFormRecordPositionText(Me)
'
' Для подчиненной формы:
'
'   Call MoveToNextExistingRecord(Me!ИмяПодчиненнойФормы.Form)
'
' ============================================================


' ------------------------------------------------------------
' Глобальный флаг служебной операции.
'
' Используется в Form_Current:
'
'   If gFormRecordOperationBusy = True Then Exit Sub
'
' Это нужно, чтобы при удалении/переходах счетчик не обновлялся
' в промежуточном состоянии формы.
' ------------------------------------------------------------
Public gFormRecordOperationBusy As Boolean


' ------------------------------------------------------------
' Сохранить текущую запись формы
' ------------------------------------------------------------
Public Function SaveCurrentFormRecord( _
    ByVal frm As Access.Form, _
    Optional ByVal ShowSuccessMessage As Boolean = False, _
    Optional ByVal SuccessMessage As String = "Запись сохранена.", _
    Optional ByVal ShowErrors As Boolean = True) As Boolean

    On Error GoTo ErrHandler

    SaveCurrentFormRecord = False

    If frm Is Nothing Then Exit Function

    ' Если запись изменена — сохраняем её
    If frm.Dirty Then
        frm.Dirty = False
    End If

    If ShowSuccessMessage = True Then
        MsgBox SuccessMessage, vbInformation, "Сохранение"
    End If

    SaveCurrentFormRecord = True

    Exit Function

ErrHandler:

    If ShowErrors = True Then
        MsgBox "Ошибка при сохранении записи:" & vbCrLf & _
               Err.Number & " - " & Err.Description, _
               vbCritical, "Сохранение записи"
    End If

    SaveCurrentFormRecord = False

End Function


' ------------------------------------------------------------
' Создать новую запись
'
' Важно:
'   Используется DoCmd.GoToRecord acNewRec.
'   Если процедура вызывается из самой формы — работает штатно.
'
'   Если кнопка находится на родительской форме и управляет
'   подчиненной формой, перед вызовом лучше поставить фокус
'   на элемент подчиненной формы.
' ------------------------------------------------------------
Public Function CreateNewFormRecord( _
    ByVal frm As Access.Form, _
    Optional ByVal SaveCurrentBeforeCreate As Boolean = True, _
    Optional ByVal ShowErrors As Boolean = True) As Boolean

    On Error GoTo ErrHandler

    CreateNewFormRecord = False
    gFormRecordOperationBusy = True

    If frm Is Nothing Then GoTo ExitHere

    ' Проверяем, разрешено ли добавление записей
    If frm.AllowAdditions = False Then

        MsgBox "Добавление новых записей для этой формы запрещено.", _
               vbExclamation, "Создание записи"

        GoTo ExitHere

    End If

    ' Сохраняем текущую запись перед созданием новой
    If SaveCurrentBeforeCreate = True Then

        If SaveCurrentFormRecord(frm, False, , ShowErrors) = False Then
            GoTo ExitHere
        End If

    End If

    ' Пытаемся установить фокус на форму
    On Error Resume Next
    frm.SetFocus
    On Error GoTo ErrHandler

    ' Переходим на новую запись
    DoCmd.GoToRecord , , acNewRec

    CreateNewFormRecord = True

ExitHere:

    gFormRecordOperationBusy = False

    Exit Function

ErrHandler:

    gFormRecordOperationBusy = False

    If ShowErrors = True Then
        MsgBox "Ошибка при создании новой записи:" & vbCrLf & _
               Err.Number & " - " & Err.Description, _
               vbCritical, "Создание записи"
    End If

    CreateNewFormRecord = False

End Function


' ------------------------------------------------------------
' Удалить текущую запись формы
'
' Удаление выполняется через RecordsetClone и Bookmark,
' поэтому процедура корректно работает:
'   - при удалении первой записи;
'   - при удалении последней записи;
'   - при удалении единственной записи;
'   - с обычными формами;
'   - с подчиненными формами.
' ------------------------------------------------------------
Public Function DeleteCurrentFormRecord( _
    ByVal frm As Access.Form, _
    Optional ByVal ConfirmDelete As Boolean = True, _
    Optional ByVal ConfirmText As String = "Удалить текущую запись?", _
    Optional ByVal ConfirmTitle As String = "Удаление записи", _
    Optional ByVal ShowSuccessMessage As Boolean = False, _
    Optional ByVal SuccessMessage As String = "Запись удалена.", _
    Optional ByVal ShowErrors As Boolean = True) As Boolean

    On Error GoTo ErrHandler

    Dim answer As VbMsgBoxResult
    Dim currentPosition As Long
    Dim recordsBeforeDelete As Long
    Dim recordsAfterDelete As Long
    Dim rs As Object

    DeleteCurrentFormRecord = False
    gFormRecordOperationBusy = True

    If frm Is Nothing Then GoTo ExitHere

    ' Новую несохраненную запись не удаляем
    If frm.NewRecord Then

        MsgBox "Новая запись ещё не сохранена. Удалять нечего.", _
               vbInformation, "Удаление записи"

        GoTo ExitHere

    End If

    ' Проверяем, разрешено ли удаление
    If frm.AllowDeletions = False Then

        MsgBox "Удаление записей для этой формы запрещено.", _
               vbExclamation, "Удаление записи"

        GoTo ExitHere

    End If

    ' Считаем записи до удаления
    recordsBeforeDelete = GetFormRecordCount(frm)

    If recordsBeforeDelete = 0 Then

        MsgBox "Нет записей для удаления.", _
               vbInformation, "Удаление записи"

        GoTo ExitHere

    End If

    ' Если запись изменена — сначала сохраняем её
    If SaveCurrentFormRecord(frm, False, , ShowErrors) = False Then
        GoTo ExitHere
    End If

    ' Запоминаем текущую позицию.
    ' После удаления вернемся примерно на это же место.
    currentPosition = GetFormCurrentRecordNumber(frm)

    If currentPosition < 1 Then
        currentPosition = 1
    End If

    ' Подтверждение удаления
    If ConfirmDelete = True Then

        answer = MsgBox( _
            ConfirmText, _
            vbQuestion + vbYesNo + vbDefaultButton2, _
            ConfirmTitle _
        )

        If answer <> vbYes Then GoTo ExitHere

    End If

    ' Удаляем текущую запись через RecordsetClone
    Set rs = frm.RecordsetClone

    rs.Bookmark = frm.Bookmark
    rs.Delete

    rs.Close
    Set rs = Nothing

    ' Обновляем форму после удаления
    frm.Requery

    ' Считаем записи после удаления
    recordsAfterDelete = GetFormRecordCount(frm)

    ' Если записи ещё остались — переходим на корректную позицию
    If recordsAfterDelete > 0 Then

        ' Если удалили последнюю запись,
        ' текущая позиция станет больше количества оставшихся записей.
        ' Тогда переходим на новую последнюю запись.
        If currentPosition > recordsAfterDelete Then
            currentPosition = recordsAfterDelete
        End If

        If currentPosition < 1 Then
            currentPosition = 1
        End If

        Call MoveToRecordNumberCore(frm, currentPosition)

    End If

    If ShowSuccessMessage = True Then
        MsgBox SuccessMessage, vbInformation, "Удаление записи"
    End If

    DeleteCurrentFormRecord = True

ExitHere:

    gFormRecordOperationBusy = False

    Exit Function

ErrHandler:

    gFormRecordOperationBusy = False

    If ShowErrors = True Then
        MsgBox "Ошибка при удалении записи:" & vbCrLf & _
               Err.Number & " - " & Err.Description, _
               vbCritical, "Удаление записи"
    End If

    DeleteCurrentFormRecord = False

End Function


' ------------------------------------------------------------
' Переход к следующей существующей записи
'
' Главное отличие от DoCmd.GoToRecord acNext:
'   процедура НЕ переходит на новую пустую запись.
'
' Если текущая запись последняя — остаемся на ней.
' ------------------------------------------------------------
Public Function MoveToNextExistingRecord( _
    ByVal frm As Access.Form, _
    Optional ByVal SaveBeforeMove As Boolean = True, _
    Optional ByVal ShowBoundaryMessage As Boolean = False, _
    Optional ByVal BoundaryMessage As String = "Это последняя запись.", _
    Optional ByVal ShowErrors As Boolean = True) As Boolean

    On Error GoTo ErrHandler

    Dim rs As Object
    Dim recordsCount As Long

    MoveToNextExistingRecord = False
    gFormRecordOperationBusy = True

    If frm Is Nothing Then GoTo ExitHere

    recordsCount = GetFormRecordCount(frm)

    If recordsCount = 0 Then

        If ShowBoundaryMessage = True Then
            MsgBox "Нет записей.", vbInformation, "Переход по записям"
        End If

        GoTo ExitHere

    End If

    ' Перед переходом сохраняем текущую запись
    If SaveBeforeMove = True Then

        If SaveCurrentFormRecord(frm, False, , ShowErrors) = False Then
            GoTo ExitHere
        End If

    End If

    ' Если сейчас новая запись, не идём дальше в новую.
    ' Возвращаемся на последнюю существующую запись.
    If frm.NewRecord Then

        Call MoveToRecordNumberCore(frm, recordsCount)

        GoTo ExitHere

    End If

    Set rs = frm.RecordsetClone

    rs.Bookmark = frm.Bookmark
    rs.MoveNext

    If rs.EOF Then

        ' Это последняя запись.
        ' Никуда не переходим.
        If ShowBoundaryMessage = True Then
            MsgBox BoundaryMessage, vbInformation, "Переход по записям"
        End If

    Else

        frm.Bookmark = rs.Bookmark
        MoveToNextExistingRecord = True

    End If

    rs.Close
    Set rs = Nothing

ExitHere:

    gFormRecordOperationBusy = False

    Exit Function

ErrHandler:

    gFormRecordOperationBusy = False

    If ShowErrors = True Then
        MsgBox "Ошибка при переходе к следующей записи:" & vbCrLf & _
               Err.Number & " - " & Err.Description, _
               vbCritical, "Переход по записям"
    End If

    MoveToNextExistingRecord = False

End Function


' ------------------------------------------------------------
' Переход к предыдущей существующей записи
'
' Если текущая запись первая — остаемся на первой записи.
' Ошибку "начальная запись - 1" не получаем.
' ------------------------------------------------------------
Public Function MoveToPreviousExistingRecord( _
    ByVal frm As Access.Form, _
    Optional ByVal SaveBeforeMove As Boolean = True, _
    Optional ByVal ShowBoundaryMessage As Boolean = False, _
    Optional ByVal BoundaryMessage As String = "Это первая запись.", _
    Optional ByVal ShowErrors As Boolean = True) As Boolean

    On Error GoTo ErrHandler

    Dim rs As Object
    Dim recordsCount As Long

    MoveToPreviousExistingRecord = False
    gFormRecordOperationBusy = True

    If frm Is Nothing Then GoTo ExitHere

    recordsCount = GetFormRecordCount(frm)

    If recordsCount = 0 Then

        If ShowBoundaryMessage = True Then
            MsgBox "Нет записей.", vbInformation, "Переход по записям"
        End If

        GoTo ExitHere

    End If

    ' Перед переходом сохраняем текущую запись
    If SaveBeforeMove = True Then

        If SaveCurrentFormRecord(frm, False, , ShowErrors) = False Then
            GoTo ExitHere
        End If

    End If

    ' Если сейчас новая запись — возвращаемся на последнюю существующую
    If frm.NewRecord Then

        MoveToPreviousExistingRecord = MoveToRecordNumberCore(frm, recordsCount)

        GoTo ExitHere

    End If

    Set rs = frm.RecordsetClone

    rs.Bookmark = frm.Bookmark
    rs.MovePrevious

    If rs.BOF Then

        ' Это первая запись.
        ' Никуда не переходим.
        If ShowBoundaryMessage = True Then
            MsgBox BoundaryMessage, vbInformation, "Переход по записям"
        End If

    Else

        frm.Bookmark = rs.Bookmark
        MoveToPreviousExistingRecord = True

    End If

    rs.Close
    Set rs = Nothing

ExitHere:

    gFormRecordOperationBusy = False

    Exit Function

ErrHandler:

    gFormRecordOperationBusy = False

    If ShowErrors = True Then
        MsgBox "Ошибка при переходе к предыдущей записи:" & vbCrLf & _
               Err.Number & " - " & Err.Description, _
               vbCritical, "Переход по записям"
    End If

    MoveToPreviousExistingRecord = False

End Function


' ------------------------------------------------------------
' Перейти на последнюю существующую запись
'
' Используется, например, при загрузке формы.
' Не переходит на новую пустую запись.
' ------------------------------------------------------------
Public Function GoToLastExistingRecord( _
    ByVal frm As Access.Form, _
    Optional ByVal ShowErrors As Boolean = True) As Boolean

    On Error GoTo ErrHandler

    Dim recordsCount As Long

    GoToLastExistingRecord = False
    gFormRecordOperationBusy = True

    If frm Is Nothing Then GoTo ExitHere

    recordsCount = GetFormRecordCount(frm)

    If recordsCount = 0 Then GoTo ExitHere

    GoToLastExistingRecord = MoveToRecordNumberCore(frm, recordsCount)

ExitHere:

    gFormRecordOperationBusy = False

    Exit Function

ErrHandler:

    gFormRecordOperationBusy = False

    If ShowErrors = True Then
        MsgBox "Ошибка при переходе на последнюю запись:" & vbCrLf & _
               Err.Number & " - " & Err.Description, _
               vbCritical, "Переход по записям"
    End If

    GoToLastExistingRecord = False

End Function


' ------------------------------------------------------------
' Перейти на первую существующую запись
' ------------------------------------------------------------
Public Function GoToFirstExistingRecord( _
    ByVal frm As Access.Form, _
    Optional ByVal ShowErrors As Boolean = True) As Boolean

    On Error GoTo ErrHandler

    Dim recordsCount As Long

    GoToFirstExistingRecord = False
    gFormRecordOperationBusy = True

    If frm Is Nothing Then GoTo ExitHere

    recordsCount = GetFormRecordCount(frm)

    If recordsCount = 0 Then GoTo ExitHere

    GoToFirstExistingRecord = MoveToRecordNumberCore(frm, 1)

ExitHere:

    gFormRecordOperationBusy = False

    Exit Function

ErrHandler:

    gFormRecordOperationBusy = False

    If ShowErrors = True Then
        MsgBox "Ошибка при переходе на первую запись:" & vbCrLf & _
               Err.Number & " - " & Err.Description, _
               vbCritical, "Переход по записям"
    End If

    GoToFirstExistingRecord = False

End Function


' ------------------------------------------------------------
' Получить текст позиции записи
'
' По умолчанию возвращает:
'   "5 из 35"
'
' Для новой записи:
'   "Новая запись"
'
' Если записей нет:
'   "0 из 0"
' ------------------------------------------------------------
Public Function GetFormRecordPositionText( _
    ByVal frm As Access.Form, _
    Optional ByVal SeparatorText As String = " из ", _
    Optional ByVal EmptyText As String = "0 из 0", _
    Optional ByVal NewRecordText As String = "Новая запись") As String

    On Error GoTo ErrHandler

    Dim recordsCount As Long
    Dim currentNumber As Long

    GetFormRecordPositionText = EmptyText

    If frm Is Nothing Then Exit Function

    recordsCount = GetFormRecordCount(frm)

    If recordsCount = 0 Then

        If frm.NewRecord Then
            GetFormRecordPositionText = NewRecordText
        Else
            GetFormRecordPositionText = EmptyText
        End If

        Exit Function

    End If

    If frm.NewRecord Then

        GetFormRecordPositionText = NewRecordText

        Exit Function

    End If

    currentNumber = GetFormCurrentRecordNumber(frm)

    If currentNumber < 1 Then currentNumber = 1
    If currentNumber > recordsCount Then currentNumber = recordsCount

    GetFormRecordPositionText = CStr(currentNumber) & SeparatorText & CStr(recordsCount)

    Exit Function

ErrHandler:

    GetFormRecordPositionText = EmptyText

End Function


' ------------------------------------------------------------
' Обновить счетчик записей в элементе управления
'
' CounterControlName:
'   имя поля/надписи на форме.
'
' Поддерживает:
'   - текстовое поле;
'   - надпись.
' ------------------------------------------------------------
Public Sub UpdateFormRecordCounter( _
    ByVal targetFrm As Access.Form, _
    ByVal CounterControlName As String, _
    Optional ByVal uiFrm As Access.Form = Nothing, _
    Optional ByVal SeparatorText As String = " из ", _
    Optional ByVal EmptyText As String = "0 из 0", _
    Optional ByVal NewRecordText As String = "Новая запись", _
    Optional ByVal ShowErrors As Boolean = True)

    On Error GoTo ErrHandler

    Dim counterText As String

    If targetFrm Is Nothing Then Exit Sub
    If Len(Trim(CounterControlName)) = 0 Then Exit Sub

    If uiFrm Is Nothing Then
        Set uiFrm = targetFrm
    End If

    counterText = GetFormRecordPositionText( _
        frm:=targetFrm, _
        SeparatorText:=SeparatorText, _
        EmptyText:=EmptyText, _
        NewRecordText:=NewRecordText _
    )

    Call SetControlText(uiFrm.Controls(CounterControlName), counterText)

    Exit Sub

ErrHandler:

    If ShowErrors = True Then
        MsgBox "Ошибка при обновлении счетчика записей:" & vbCrLf & _
               Err.Number & " - " & Err.Description, _
               vbExclamation, "Счетчик записей"
    End If

End Sub


' ------------------------------------------------------------
' Обновить счетчик и состояние кнопок
'
' targetFrm:
'   форма, по записям которой работаем.
'
' uiFrm:
'   форма, на которой находятся кнопки и счетчик.
'
' Если кнопки находятся на той же форме, что и записи,
' uiFrm можно не указывать.
'
' Если кнопки находятся на родительской форме,
' а управляют подчиненной формой:
'
'   targetFrm := Me!ПодчиненнаяФорма.Form
'   uiFrm     := Me
' ------------------------------------------------------------
Public Sub RefreshFormRecordNavigationUi( _
    ByVal targetFrm As Access.Form, _
    Optional ByVal uiFrm As Access.Form = Nothing, _
    Optional ByVal CounterControlName As String = "", _
    Optional ByVal ButtonSaveName As String = "", _
    Optional ByVal ButtonCreateName As String = "", _
    Optional ByVal ButtonDeleteName As String = "", _
    Optional ByVal ButtonNextName As String = "", _
    Optional ByVal ButtonPreviousName As String = "", _
    Optional ByVal SeparatorText As String = " из ", _
    Optional ByVal EmptyText As String = "0 из 0", _
    Optional ByVal NewRecordText As String = "Новая запись")

    On Error Resume Next

    Dim recordsCount As Long
    Dim currentNumber As Long

    If targetFrm Is Nothing Then Exit Sub

    If uiFrm Is Nothing Then
        Set uiFrm = targetFrm
    End If

    recordsCount = GetFormRecordCount(targetFrm)
    currentNumber = GetFormCurrentRecordNumber(targetFrm)

    ' Счетчик записей
    If Len(Trim(CounterControlName)) > 0 Then

        Call UpdateFormRecordCounter( _
            targetFrm:=targetFrm, _
            CounterControlName:=CounterControlName, _
            uiFrm:=uiFrm, _
            SeparatorText:=SeparatorText, _
            EmptyText:=EmptyText, _
            NewRecordText:=NewRecordText, _
            ShowErrors:=False _
        )

    End If

    ' Кнопка "Сохранить"
    If Len(Trim(ButtonSaveName)) > 0 Then

        Call SetControlEnabled( _
            uiFrm.Controls(ButtonSaveName), _
            (targetFrm.AllowEdits = True Or targetFrm.AllowAdditions = True) _
        )

    End If

    ' Кнопка "Создать"
    If Len(Trim(ButtonCreateName)) > 0 Then

        Call SetControlEnabled( _
            uiFrm.Controls(ButtonCreateName), _
            targetFrm.AllowAdditions _
        )

    End If

    ' Кнопка "Удалить"
    If Len(Trim(ButtonDeleteName)) > 0 Then

        Call SetControlEnabled( _
            uiFrm.Controls(ButtonDeleteName), _
            (recordsCount > 0 And targetFrm.NewRecord = False And targetFrm.AllowDeletions = True) _
        )

    End If

    ' Кнопка "Назад"
    If Len(Trim(ButtonPreviousName)) > 0 Then

        Call SetControlEnabled( _
            uiFrm.Controls(ButtonPreviousName), _
            (recordsCount > 0 And ((targetFrm.NewRecord = True) Or (currentNumber > 1))) _
        )

    End If

    ' Кнопка "Далее"
    If Len(Trim(ButtonNextName)) > 0 Then

        Call SetControlEnabled( _
            uiFrm.Controls(ButtonNextName), _
            (recordsCount > 0 And targetFrm.NewRecord = False And currentNumber < recordsCount) _
        )

    End If

End Sub


' ------------------------------------------------------------
' Получить количество текущих записей формы
'
' Учитывает:
'   - источник записей формы;
'   - текущий фильтр;
'   - текущий набор записей.
' ------------------------------------------------------------
Public Function GetFormRecordCount(ByVal frm As Access.Form) As Long

    On Error GoTo ErrHandler

    Dim rs As Object

    GetFormRecordCount = 0

    If frm Is Nothing Then Exit Function

    Set rs = frm.RecordsetClone

    If rs.BOF And rs.EOF Then

        GetFormRecordCount = 0

    Else

        rs.MoveLast
        GetFormRecordCount = rs.RecordCount

    End If

    rs.Close
    Set rs = Nothing

    Exit Function

ErrHandler:

    GetFormRecordCount = 0

End Function


' ------------------------------------------------------------
' Получить номер текущей записи
'
' Для обычной записи используется frm.CurrentRecord.
' Для новой записи возвращается Count + 1.
' ------------------------------------------------------------
Public Function GetFormCurrentRecordNumber(ByVal frm As Access.Form) As Long

    On Error GoTo ErrHandler

    If frm Is Nothing Then

        GetFormCurrentRecordNumber = 0

    ElseIf frm.NewRecord Then

        GetFormCurrentRecordNumber = GetFormRecordCount(frm) + 1

    Else

        GetFormCurrentRecordNumber = frm.CurrentRecord

    End If

    Exit Function

ErrHandler:

    GetFormCurrentRecordNumber = 0

End Function


' ------------------------------------------------------------
' Публичный переход к записи по номеру
'
' recordNumber:
'   1 — первая запись;
'   2 — вторая запись;
'   и т.д.
' ------------------------------------------------------------
Public Function MoveToFormRecordNumber( _
    ByVal frm As Access.Form, _
    ByVal recordNumber As Long, _
    Optional ByVal ShowErrors As Boolean = True) As Boolean

    On Error GoTo ErrHandler

    MoveToFormRecordNumber = False
    gFormRecordOperationBusy = True

    If frm Is Nothing Then GoTo ExitHere

    MoveToFormRecordNumber = MoveToRecordNumberCore(frm, recordNumber)

ExitHere:

    gFormRecordOperationBusy = False

    Exit Function

ErrHandler:

    gFormRecordOperationBusy = False

    If ShowErrors = True Then
        MsgBox "Ошибка при переходе к записи №" & recordNumber & ":" & vbCrLf & _
               Err.Number & " - " & Err.Description, _
               vbExclamation, "Переход к записи"
    End If

    MoveToFormRecordNumber = False

End Function


' ------------------------------------------------------------
' Внутренняя функция перехода к записи по номеру
'
' Не управляет gFormRecordOperationBusy.
' Используется внутри других процедур модуля.
' ------------------------------------------------------------
Private Function MoveToRecordNumberCore( _
    ByVal frm As Access.Form, _
    ByVal recordNumber As Long) As Boolean

    On Error GoTo ErrHandler

    Dim rs As Object
    Dim recordsCount As Long

    MoveToRecordNumberCore = False

    If frm Is Nothing Then Exit Function

    recordsCount = GetFormRecordCount(frm)

    If recordsCount = 0 Then Exit Function

    If recordNumber < 1 Then
        recordNumber = 1
    End If

    If recordNumber > recordsCount Then
        recordNumber = recordsCount
    End If

    Set rs = frm.RecordsetClone

    rs.MoveFirst

    If recordNumber > 1 Then
        rs.Move recordNumber - 1
    End If

    frm.Bookmark = rs.Bookmark

    rs.Close
    Set rs = Nothing

    MoveToRecordNumberCore = True

    Exit Function

ErrHandler:

    MoveToRecordNumberCore = False

End Function


' ------------------------------------------------------------
' Внутренняя процедура:
' записать текст в элемент управления
'
' Поддерживает:
'   - Label / Надпись через Caption;
'   - TextBox и прочие элементы через Value.
' ------------------------------------------------------------
Private Sub SetControlText( _
    ByVal ctl As Access.Control, _
    ByVal textValue As String)

    On Error Resume Next

    If ctl Is Nothing Then Exit Sub

    Select Case ctl.ControlType

        Case acLabel
            ctl.Caption = textValue

        Case Else
            ctl.Value = textValue

    End Select

End Sub


' ------------------------------------------------------------
' Внутренняя процедура:
' включить/отключить элемент управления
' ------------------------------------------------------------
Private Sub SetControlEnabled( _
    ByVal ctl As Access.Control, _
    ByVal enabledValue As Boolean)

    On Error Resume Next

    If ctl Is Nothing Then Exit Sub

    ctl.Enabled = enabledValue

End Sub

Минимальный код в форме

В форме, где стоят кнопки Сохранить, Создать, Удалить, Далее, Назад и поле/надпись Нумерация, оставляешь такой код:

Option Compare Database
Option Explicit


' ------------------------------------------------------------
' При загрузке формы открываем последнюю существующую запись
' ------------------------------------------------------------
Private Sub Form_Load()

    Call GoToLastExistingRecord(Me)

    Me.Нумерация = GetFormRecordPositionText(Me)

End Sub


' ------------------------------------------------------------
' При переходе между записями обновляем счетчик
' ------------------------------------------------------------
Private Sub Form_Current()

    ' Если сейчас выполняется служебная операция удаления/перехода,
    ' не обновляем счетчик в промежуточном состоянии формы
    If gFormRecordOperationBusy = True Then Exit Sub

    Me.Нумерация = GetFormRecordPositionText(Me)

End Sub


' ------------------------------------------------------------
' После добавления записи обновляем счетчик
' ------------------------------------------------------------
Private Sub Form_AfterInsert()

    Me.Нумерация = GetFormRecordPositionText(Me)

End Sub


' ------------------------------------------------------------
' После удаления записи обновляем счетчик
' ------------------------------------------------------------
Private Sub Form_AfterDelConfirm(Status As Integer)

    Me.Нумерация = GetFormRecordPositionText(Me)

End Sub


' ------------------------------------------------------------
' Кнопка "Сохранить"
' ------------------------------------------------------------
Private Sub Сохранить_Click()

    If SaveCurrentFormRecord(Me) = True Then

        Me.Нумерация = GetFormRecordPositionText(Me)

    End If

End Sub


' ------------------------------------------------------------
' Кнопка "Создать"
' ------------------------------------------------------------
Private Sub Создать_Click()

    If CreateNewFormRecord(Me) = True Then

        Me.Нумерация = GetFormRecordPositionText(Me)

    End If

End Sub


' ------------------------------------------------------------
' Кнопка "Удалить"
' ------------------------------------------------------------
Private Sub Удалить_Click()

    If DeleteCurrentFormRecord(Me) = True Then

        Me.Нумерация = GetFormRecordPositionText(Me)

    End If

End Sub


' ------------------------------------------------------------
' Кнопка "Далее"
' ------------------------------------------------------------
Private Sub Далее_Click()

    Call MoveToNextExistingRecord(Me)

    Me.Нумерация = GetFormRecordPositionText(Me)

End Sub


' ------------------------------------------------------------
' Кнопка "Назад"
' ------------------------------------------------------------
Private Sub Назад_Click()

    Call MoveToPreviousExistingRecord(Me)

    Me.Нумерация = GetFormRecordPositionText(Me)

End Sub

Вариант с автоматическим включением/отключением кнопок

Если хочешь, чтобы кнопка Далее отключалась на последней записи, Назад на первой, а Удалить отключалась на новой записи, вместо прямого обновления Me.Нумерация = ... можно сделать локальную процедуру:

Private Sub RefreshRecordUi()

    Call RefreshFormRecordNavigationUi( _
        targetFrm:=Me, _
        CounterControlName:="Нумерация", _
        ButtonSaveName:="Сохранить", _
        ButtonCreateName:="Создать", _
        ButtonDeleteName:="Удалить", _
        ButtonNextName:="Далее", _
        ButtonPreviousName:="Назад" _
    )

End Sub

И тогда в событиях вызывать:

Call RefreshRecordUi

Например:

Private Sub Form_Current()

    If gFormRecordOperationBusy = True Then Exit Sub

    Call RefreshRecordUi

End Sub

А в кнопках:

Private Sub Далее_Click()

    Call MoveToNextExistingRecord(Me)

    Call RefreshRecordUi

End Sub

В этой версии логика из твоего старого кода сохранена: нет ухода на новую пустую запись через Далее, нет ошибки на первой записи через Назад, удаление первой/последней/единственной записи обрабатывается отдельно через позицию записи и RecordsetClone.

Back to top