'***************************************************************
' Подписка: "Access 2000 - программирование и готовые решения"
' Тема: Работа с внешним бинарным файлом
' Версия: 1 от 02.09.2002
' Автор: Copyright © LeaderAccess, LTD
' Сайт: http://www.leadersoft.ru
' Почта: support@leadersoft.ru
' Примечание: При использовании в коммерческих целях - оплата 100 рублей
'
Option Compare Database
Option Explicit
'==============================================================
' При загрузке формы загружаем файлы
Private Sub Form_Load()
funAutoReadAllFiles Application.CurrentProject.Path, "*.txt"
End Sub
'==============================================================
' Прочитаем имена файлов и загрузим их в таблицу
'
Private Sub funAutoReadAllFiles(strDir As String, strFileExt As String)
Dim i 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
|