Форумы HiProg.com - MS ACCESS, VBA, VB

ник: АлексейЕ
- поле в таблице, в которой будет указываться номер строки (Number) ;
- ленточная форма с источником строк с сортировкой по полю номера строки;
- две кнопки вверх (cmdUp) и вниз (cmdDown);
- ниже указанный код в модуле формы.

Private blnRecordDelete     As Boolean  ' Флаг удаления Private intRecordNumber     As Integer  ' Номер записи после которой произошло удаление ' Имя поля в котором храним номера строк Private Const strcNameFieldNumber  As String = "Number" '============================================= '               ФОРМА '============================================= Private Sub Form_BeforeInsert(Cancel As Integer) Dim rst As Object     ' Присвоим порядковый номер новой записе     Set rst = Me.RecordsetClone     If rst.RecordCount > 0 Then rst.MoveLast     Me.Controls(strcNameFieldNumber) = rst.RecordCount + 1     Set rst = Nothing End Sub Private Sub Form_Current()     If blnRecordDelete And intRecordNumber > 0 Then DeleteRecord End Sub Private Sub Form_Delete(Cancel As Integer) Dim rst As Object On Error Resume Next     ' Что бы при множественном удалении не переписывать номера записей после каждой удаленной     ' выставим флаги удаления, а перепись организуем в событии Текущая запись     Set rst = Me.RecordsetClone     rst.Bookmark = Me.Bookmark     If Err.Number > 0 Then Set rst = Nothing: Exit Sub     intRecordNumber = rst.AbsolutePosition     blnRecordDelete = True     Set rst = Nothing End Sub '============================================= '               КОНТРОЛ '============================================= Private Sub cmdUp_Click()     MoveRecord True End Sub Private Sub cmdDown_Click()     MoveRecord False End Sub '============================================= '               ПРОЧЕЕ '============================================= Private Sub MoveRecord(blnUpward As Boolean) Dim rst             As Object Dim pos             As Integer Dim bytRecType      As Byte     ' Тип рекордсета, он же и корректор для .AbsolutePosition          ' Сохраним внесенные изменения     Me.Dirty = False          Set rst = Me.RecordsetClone     bytRecType = GetTypeRecordset(rst)          With rst         .Bookmark = Me.Bookmark         ' Проверим не является ли передвигаемая строка первой или последней, и если да, то ни чего не делаем         If Not (Not blnUpward And (.AbsolutePosition = .RecordCount + (bytRecType - 1)) Or _                    (blnUpward And (.AbsolutePosition = (0 + bytRecType)))) Then                          ' Откроем транзакцию (малоли что... а так сразу у обеих строк меняем номер, или не меняем)             If Transaction("BeginTrans", bytRecType) Then                 On Error GoTo ErrorTrans                              ' Если передвигаем вверх, то перейдем на предыдущую строку                 If blnUpward Then .MovePrevious:    pos = .AbsolutePosition                 ' Начнем передвижение строк                 RecordEdit rst, bytRecType, .AbsolutePosition + (2 - bytRecType)                 .MoveNext                 RecordEdit rst, bytRecType, .AbsolutePosition - bytRecType                                  ' Сохраним транзакцию                 Call Transaction("CommitTrans", bytRecType)                 On Error GoTo 0                                  ' Обновляем форму и выставляемся на перемещаемую запись                 If Not blnUpward Then pos = .AbsolutePosition                 Me.Requery                 Me.Recordset.AbsolutePosition = pos             End If         End If     End With          Set rst = Nothing     Exit Sub      ErrorTrans:     Call Transaction("RollbackTrans", bytRecType)     Set rst = Nothing End Sub Private Sub DeleteRecord() Dim rst             As Object Dim pos             As Integer Dim bytRecType      As Byte     Set rst = Me.RecordsetClone     bytRecType = GetTypeRecordset(rst)     pos = intRecordNumber          ' Ну куда же мы без транзакции     If Transaction("BeginTrans", bytRecType) Then         On Error GoTo ErrorTrans                  With rst             ' Пробежимся по записям после удаленых и перепишем номера             .AbsolutePosition = intRecordNumber             Do Until .EOF                 RecordEdit rst, bytRecType, .AbsolutePosition + 1                 .MoveNext             Loop         End With                  Call Transaction("CommitTrans", bytRecType)         On Error GoTo 0                  blnRecordDelete = False:    intRecordNumber = 0         Me.Requery         If Me.NewRecord And rst.RecordCount > 0 Then Me.Recordset.MoveLast Else Me.Recordset.AbsolutePosition = pos              End If     Set rst = Nothing     Exit Sub      ErrorTrans:     Call Transaction("RollbackTrans", bytRecType)     Set rst = Nothing     blnRecordDelete = False:    intRecordNumber = 0 End Sub ' Вернет 1 - если рекордсет ADO, и 0 - если DAO Private Function GetTypeRecordset(ByRef objRecordset As Object) As Byte Dim bkm As Variant          On Error Resume Next     With objRecordset         'Запомиаем закладку, что бы ее востановить по окончании         bkm = .Bookmark         .MoveFirst         GetTypeRecordset = .AbsolutePosition         'Востанавливае текущую запись, т.к. рекордсет передовали 'по ссылке'.         .Bookmark = bkm     End With End Function ' Функция для работы с транзакцией Private Function Transaction(strMethodTrans As String, bytTypeRecordset As Byte) As Byte Dim trn         As Object     On Error GoTo ErrorTrans          If bytTypeRecordset = 0 Then         Set trn = Application.DBEngine.Workspaces(0)     Else         Set trn = CurrentProject.Connection     End If          Select Case strMethodTrans     Case "BeginTrans"         trn.BeginTrans     Case "CommitTrans"         trn.CommitTrans     Case Else         If bytTypeRecordset = 0 Then trn.Rollback Else trn.RollbackTrans     End Select          Transaction = True          Exit Function      ErrorTrans:     Transaction = False End Function ' Процедура изменения строки в рекордсете Private Sub RecordEdit(ByRef objRecordset As Object, bytTypeRecordset As Byte, intNewNumber As Integer)     ' Eсли рекордсет DAO то вызовим метод Edit     If bytTypeRecordset = 0 Then objRecordset.Edit     objRecordset.Fields(strcNameFieldNumber) = intNewNumber     objRecordset.Update End Sub

Код универсальный, будет работать как в mdb базах (DAO рекордсет), так и в adp проектах (ADO рекордсет)