TopPicLogo TopPicText

Перебор всех записей (DAO)

Private Sub AllRecordsInRecordset()
'Перебор всех записей в наборе
Dim rst As DAO.Recordset
On Error GoTo AllRecordsInRecordsetErr
    
    'Set rst = CurrentDb.OpenRecordset("tblExample", dbOpenDynaset)   'Открытие на редакцию
    Set rst = CurrentDb.OpenRecordset("tblExample", dbOpenSnapshot)  'Только просмотр
    
    With rst 
        Do Until .EOF = True 'Цикл до конца таблицы
            Debug.Print Format(!exRecordID, "00000") & " - " & !exName
            '...
            '...операции с записью
            .MoveNext
        Loop
    End With

AllRecordsInRecordsetEnd:
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    Exit Sub
    
AllRecordsInRecordsetErr:
    MsgBox "Процедура [...] привела к ошибке:" & vbCrLf & _
    Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical
    Resume AllRecordsInRecordsetEnd
End Sub


Пример перебора записей с обновлением данных таблицы:

Private Sub FileSizesToTable()
'Установка размеров файлов в таблице файлов
'--------------------------------------------------------------------------
Dim rst As DAO.Recordset
Dim lFileLen As Long
Dim s$

On Error GoTo FileSizesToTable_Err
    'Выборка строк где размер файлов не проставлен (itfSizeBytes=0)
    s = "SELECT * FROM dtItemsFiles WHERE (itfSizeBytes=0)"
    Set rst = CurrentDb.OpenRecordset(s, dbOpenDynaset)   'Открытие на редакцию
    
    With rst
        Do Until .EOF = True 'Цикл до конца таблицы
            '...операции с записью
            s = !itfName 'Имя файла
            'тут conFileStorige = относительная папка типа "\ProgectData\Files\"
            s = CurrentProject.Path & conFileStorige & s 'получили полный путь к файлу
            
            If Dir(s) <> "" Then 'если файл существует
                .Edit   ' ВКЛ. режим редактирования
                lFileLen = FileLen(s)      ' получаем размер файла в байтах
                !itfSizeBytes = lFileLen   ' и записываем его
                .Update ' Сохранили ...
                'Debug.Print Format(lFileLen, "000 000 000") & " - " & !itfName
            End If
            .MoveNext 'Переход к следующей записи
        Loop
    End With

FileSizesToTable_End:
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    Exit Sub
    
FileSizesToTable_Err:
    MsgBox "Процедура [FileSizesToTable] привела к ошибке:" & vbCrLf & _
    Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical, "Ошибка!"
    Resume FileSizesToTable_End
End Sub

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