MyTetra Share
Делитесь знаниями!
Нумерация записей в таблице (DAO)
19.07.2018
06:43
Раздел: VBA - Access - msa.polarcom.ru - 04 Наборы Записей

Нумерация записей в таблице (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





 
MyTetra Share v.0.52
Яндекс индекс цитирования