MyTetra Share
Делитесь знаниями!
Автозагрузка файлов в таблицу
Время создания: 16.03.2019 23:43
Раздел: !Закладки - VBA - Access - leadersoft.ru
Запись: xintrea/mytetra_db_adgaver_new/master/base/1531370525b3tv25dgan/text.html на raw.githubusercontent.com

Автозагрузка файлов в таблицу

Для быстрой загрузки всех файлов в таблицу можно использовать этот способ. Применяйте его, например, для обработки html файлов


 Microsoft Office: 2000,2002,2003,2007,2010

 Архив с файлами: Перейти

 Операционная система: Windows XP,Vista

 Применение: Базы данных Access

 Продажа: Купить

 Файл исходника: ..\Access\14 Файлы\la_files.mdb

 Язык интерфейса: Русский


 

 


' При загрузке формы загружаем файлы
Private Sub Form_Load()
    funAutoReadAllFiles Application.CurrentProject.Path, 
"*.txt"
End Sub



' Прочитаем имена файлов и загрузим их в таблицу
Private Sub funAutoReadAllFiles(strDir As String, strFileExt As String)
Dim As Long, rst As DAO.Recordset
On Error GoTo 999
        
With Application.FileSearch
           .NewSearch
           .LookIn = strDir 
' *.name
           .FILENAME = strFileExt 
' *.txt
           .SearchSubFolders = 
False
           
If .Execute(SortBy:=msoSortByFileName, _
                    SortOrder:=msoSortOrderAscending) > 0 
Then
                
For i = 1 To .FoundFiles.Count
                    
If MsgBox("Загрузить файл: " & .FoundFiles(i), vbInformation + vbOKCancel, "Загрузить") = vbOK Then
                        funAutoReadOneFile .FoundFiles(i), 
"Таблица5"
                        Me.table5.Requery
                    
End If
                
Next i
           
End If
        
End With
    
Exit Sub      'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 
'Очищаем поток от ошибок
End Sub



' Загружаем файл в таблицу
Private Function funAutoReadOneFile(strFileName As String, strTable)
Dim fs, f, flag
Dim dbs As DAO.Database, rst As DAO.Recordset

    
On Error GoTo 999
    
Set fs = CreateObject("Scripting.FileSystemObject")
    
Set f = fs.GetFile(strFileName)
    
    
' Проверка файла
    
Set dbs = CurrentDb
    
Set rst = dbs.OpenRecordset("select * from " & strTable)
    
    
If rst.RecordCount Then
        rst.MoveLast
        rst.MoveFirst
    
End If
    
    rst.FindFirst 
"[FileName] = '" & strFileName & "'"
    
If rst.NoMatch = False Then
        dbs.Close
        rst.Close
        
Exit Function
    
End If
    
    
' Добавление информации о дате создания
    rst.AddNew
    rst!FILENAME = strFileName
    rst!DateCreated = f.DateCreated
    
    
' Добавление информации о содержимом
    rst!Memo = 
""
    
Set f = fs.OpenTextFile(strFileName, 1, False)
    
Do While f.AtEndOfStream <> True
        rst!Memo = rst!Memo & f.ReadLine 
' Читаем построчно
    
Loop
    f.Close
    
    
' Сохранение содержимого
    rst.Update
    rst.Close
    dbs.Close
    
    
Exit Function
999:
'Ошибка:
    MsgBox Err.Description
    Err.Clear
    rst.Close
End Function

Так же в этом разделе:
 
MyTetra Share v.0.59
Яндекс индекс цитирования