Нумерация записей в таблице (DAO)
Производит нумерацию записей в указанном поле указанной таблицы, что бывает полезно перед добавлением индекса, например.
Public Sub esRecordsNumbering(tabName As String, fldName As String, Optional StartNo As Long = 1)
'es 01.07.2011
'Нумерация записей в таблице или запросе на выборку
'--------------------------------------------------------------------
'Аргументы:
' tabName = Название Таблицы или Запроса
' fldName = Название обрабатываемого Поля
' StartNo = Начальный Номер (по умолч = 1)
'--------------------------------------------------------------------
Dim rst As DAO.Recordset
'--------------------------------------------------------------------
On Error GoTo RecNumberingErr
Set rst = CurrentDb.OpenRecordset(tabName, dbOpenDynaset)
'Если нет записей то на выход
If rst.EOF = True Then GoTo RecNumberingBye
DoCmd.Hourglass True 'Курсор = часы
With rst
'Цикл до конца таблицы
Do Until .EOF = True
.Edit
.Fields(fldName) = StartNo
.Update
StartNo = StartNo + 1
.MoveNext
Loop
End With
RecNumberingBye:
DoCmd.Hourglass False 'Вернуть нормальный курсор
On Error Resume Next
rst.Close
Set rst = Nothing
Err.Clear
Exit Sub
RecNumberingErr:
MsgBox "Процедура: esRecordsNumbering - привела к ошибке:" & vbCrLf & _
Err.Description & " ERR# " & Err.Number
Resume RecNumberingBye
End Sub
Пример эксплуатации:
Private Sub btn_frm_Click()
'Нумерация поля "nom_uved" в таблице "osnova"
esRecordsNumbering "osnova", "nom_uved", 1
End Sub
Еще вариант:
Нумерация записей в таблице с отображением хода процесса в StatusBar
Public Sub esRecordsNumberingST(tabName As String, fldName As String, _
Optional StartNo As Long = 1)
'--------------------------------------------------------------------
'es 01.07.2011
'Нумерация записей в таблице или запросе с отображением информации в StatusBar
'--------------------------------------------------------------------
'Агрументы:
' tabName = Название Таблицы
' fldName = Название Поля
' StartNo = Начальный Номер (по умолч = 1)
'--------------------------------------------------------------------
Dim rst As DAO.Recordset
Dim lngFiveProc As Long 'кол-во записей для 5% процесса
Dim z As Integer 'Счетчик процесса
'--------------------------------------------------------------------
On Error GoTo RecNumberingSTErr
Set rst = CurrentDb.OpenRecordset(tabName, dbOpenDynaset)
'Если нет записей то на выход
If rst.EOF = True Then GoTo RecNumberingSTBye
With rst
.MoveLast
.MoveFirst
'Подсчет кол-ва записей для 5% работы
lngFiveProc = CLng(.RecordCount / 20)
DoCmd.Hourglass True 'Курсор = ЧАСЫ
'Инициализация счетчика в StatusBar на 20 делений по 5% каждое
SysCmd acSysCmdInitMeter, "Нумерация записей: ", 20
'Цикл до конца таблицы
Do Until .EOF = True
.Edit
.Fields(fldName) = StartNo
.Update
StartNo = StartNo + 1
'Отображение процесса
If StartNo Mod lngFiveProc = 0 Then
z = z + 1
SysCmd acSysCmdUpdateMeter, z
End If
.MoveNext
Loop
End With
RecNumberingSTBye:
On Error Resume Next
DoCmd.Hourglass False 'Вернуть нормальный курсор
rst.Close
Set rst = Nothing
Err.Clear
SysCmd acSysCmdClearStatus 'Очистка бара
Exit Sub
RecNumberingSTErr:
MsgBox "Процедура: esRecordsNumberingST - привела к ошибке:" & vbCrLf & _
Err.Description & " ERR# " & Err.Number
Resume RecNumberingSTBye
End Sub
ADO
Public Sub RecordsNumbering(sTableName$, sFieldName$, Optional StartNo& = 1)
'es 14.12.2016
'Нумерация записей в таблице (Наборе записей) ADO
'--------------------------------------------------------------------
'Аргументы:
' sTableName = Название Таблицы
' sFieldName = Название обрабатываемого Поля
' StartNo = Начальный Номер (по умолч = 1)
'--------------------------------------------------------------------
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset 'объект набора данных
Dim sSql$
'--------------------------------------------------------------------
On Error GoTo RecordsNumbering_Err
Set cnt = CurrentProject.Connection ' Локально
cnt.CursorLocation = 2 'adUseServer (2) - adUseClient (3)
Set rst = CreateObject("ADODB.Recordset")
rst.CursorLocation = 2 'adUseServer (2) - adUseClient (3)
sSql = "SELECT " & sFieldName & " FROM " & sTableName & ";"
rst.Open sSql, cnt, adOpenDynamic, adLockOptimistic
'Если нет записей то на выход
If rst.EOF = True Then GoTo RecordsNumbering_Bye
DoCmd.Hourglass True 'Курсор = часы
With rst
'Цикл до конца таблицы
Do Until .EOF = True
.Fields(0) = StartNo
.Update
StartNo = StartNo + 1
.MoveNext
Loop
End With
RecordsNumbering_Bye:
DoCmd.Hourglass False 'Вернуть нормальный курсор
On Error Resume Next
rst.Close: Set rst = Nothing
cnt.Close: Set cnt = Nothing
Exit Sub
RecordsNumbering_Err:
MsgBox "Процедура: RecordsNumbering - привела к ошибке:" & vbCrLf & Err.Description & " ERR# " & Err.Number
Resume RecordsNumbering_Bye
End Sub
