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

Дублирование записи в форме

Private Sub cmdDuplicateRecord_Click()
'Дублирование записи формы + Копирование записей из её подчинённой формы
'Duplicatie van records van het huidige formulier samen met de gegevens van de ondergeschikte
'Duplicate form entry + Copy entries from its SubForm
'----------------------------------------------------------------
Dim i As Integer, n As Integer, v() As Variant
Dim lRecID As Long, lRecIDNew As Long
Dim strSQL As String
Const sIDFieldName$ = "ID" 'Название поля кода записи - sleutel veld naam - RecordID field name
 
On Error GoTo cmdDuplicateRecord_Click_Err
    
    Me.Dirty = False 'Сохранка! - huidige record opslaan - Saving the current form entry
    
    n = Me.Recordset.Fields.Count - 1 'кол-во полей = Размерность массива - Matrix dimensie - Number of fields = Array size
    ReDim v(n)
    
    For i = 0 To n                    'Текущие значения полей в массив - Put the current field values into an array
        v(i) = Me.Recordset.Fields(i).Value
    Next i
    
    If IsNull(Me(sIDFieldName).Value) Then
        'Nieuw item - Geen duplicatie! - New entry - Can't duplicate!
        MsgBox "Запись новая - Нельзя дублироваить!", vbExclamation
        GoTo cmdDuplicateRecord_Click_End
    End If
    'Remember the ID of the old record - to insert subordinate ...
    lRecID = Me(sIDFieldName).Value 'Запоминаем ID старой записи - для вставки подчинённых ...
    
'Добаление новой записи - Een nieuw record toevoegen :
    Me.Recordset.AddNew 'На новую запись - ga naar een nieuw record
    For i = 0 To n  'Старые значения из массива переносим в поля новой записи (кроме ID)
        If Not Me.Recordset.Fields(i).Name = sIDFieldName Then
            If Not IsEmpty(v(i)) Then Me.Recordset.Fields(i).Value = v(i)
        End If
    Next i
    Me.Recordset.Update 'Сохранение созданой записи - _
        Als u het gemaakte record opslaat, moet u ondergeschikten toevoegen
        Saving the record you just created
    
    lRecIDNew = Me(sIDFieldName).Value 'ID новой записи - для вставки подчинённых _
        Nieuw record-ID - om ondergeschikten in te voegen  ...
    
'Копируем подчинённые записи  - запросом на добавление ... _
    Copying subordinate records with a Add Query ...
    strSQL = "INSERT INTO TeamComposition ( TeamMember, MovementID ) " & _
        "SELECT TeamMember, " & lRecIDNew & " AS RecIID " & _
        "FROM TeamComposition " & _
        "WHERE (MovementID = " & lRecID & ")"
    CurrentDb.Execute strSQL 'исполняем
    
    Me!Form1.Requery
    
    MsgBox "Данные успешно скопированы!", vbOKOnly + vbInformation, "Информация"
 
cmdDuplicateRecord_Click_End:
    On Error GoTo 0
    Exit Sub
 
cmdDuplicateRecord_Click_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdDuplicateRecord_Click.", vbCritical, "Произошла ошибка!"
    Err.Clear
    Resume cmdDuplicateRecord_Click_End
 
End Sub

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