Описание: Частенько пользователь базы данных хочет по своему порядку в табличной часть документа располагать записи.
Для реализации такой возможности требуется:
- поле в таблице, в которой будет указываться номер строки (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 рекордсет)
Просмотров: 16011
 Коментарии (4) |
 |
| Добавить коментарий |