Применение модуля для Clipper
Андрей Курбацкий,
Я немного исправил Ваш модуль, так что он уже корректно работает с длинными
Char полями Клипперовских баз. Одно но - мне пришел исходник из рассылки и в нем строка переконвертации из DOS в WIN была разрушена. Всю строку я восстановил, но не совсем корректно, так что в высылаемом модуле она должна быть исправлена на корректную
(строка alfaDos As String)
' Start-->
'Attribute VB_Name = "basDbfConverter"
Option Compare Database
Option Explicit
'***************************************************************
' Подписка: "Access 2000 - программирование и готовые решения"
' Тема: Работа с внешним dbf файлом версии III или IV
' Версия: 1 от 26.03.2002
' Версия: 2 от 2.04.2002 (C) Курбацкий А.А.
' Автор: Copyright (C) LeaderAccess, LTD
' Сайт: http://www.leadersoft.ru
' Примечание: Ссылка на автора и программу обязательна!
'
Const alfaWin As String = "абвгдеёжзийклмнопрстуфхцчшщьэъюяАБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЬЭЪЮЯыЫ"
Const alfaDos As String = " ЎўЈ¤Ґс¦§Ё©Є«¬®ЇабвгдежзиймнкопЂЃ‚ѓ„…р†‡€‰Љ‹ЊЌЋЏђ‘’“”•–—™њќљћџл›"
' Заголовок, прочитанный в буфер
Public Type dbfBufHeader
buf As String * 4 ' Номер версии и дата
RecordCount As Long ' Число записей
HeaderLength As Integer ' Длина заголовка
RecordLength As Integer ' Длина записи
End Type
' Характеристика поля базы данных
Public Type dbfFields
Name As String ' Название поля
Type As String ' Тип поля
Length As Integer ' Длина поля
Dec As Integer ' Число знаков после запятой
End Type
' Данные по записи
Public Type dbfRecord
Mark As String ' 1 байт. Флаг маркировки: * - удалена или " "
Data() As String ' Данные всех полей
End Type
' Полная информация по заголовку
Public Type dbfHeader
VersionNumber As Integer ' Номер версии
LastUpdate As Date ' Дата последнего обновлен��я
HeaderLength As Integer ' Длина заголовка
RecordCount As Long ' Число записей
RecordLength As Integer ' Длина записи
NumberFields As Integer ' Число полей
FileSize As Long ' Размер файла
PathDBF As String ' Имя файла
PathDBT As String ' Имя файла
TableAccess As String ' Таблица в Mdb файле
Fields() As dbfFields ' Данные по полям
Record As dbfRecord ' Информация по 1 записи
DBF As Integer ' Указатель на DBF файл
DBT As Integer ' Указатель на MEMO файл
End Type
'==============================================================
' Прочитать данные о заголовке dbf файла
' и сохранить данные в структуре hDbf
'
Function dbfReadHeader(hDbf As dbfHeader, strPath As String, strTableAccess As String) As Long
Dim bufHdr As dbfBufHeader ' Заголовок - буфер
hDbf.DBF = FreeFile() ' Создаем указатель
With hDbf
Open strPath For Binary As #.DBF
Get #.DBF, , bufHdr ' Читаем заголовок
.PathDBF = strPath
.TableAccess = strTableAccess
.VersionNumber = Asc(Left$(bufHdr.buf, 1)) And (7) ' Номер версии
.LastUpdate = dbfReadDate(Mid$(bufHdr.buf, 2, 3)) ' Дата
.RecordCount = bufHdr.RecordCount ' Число записей
.HeaderLength = bufHdr.HeaderLength ' Длина заголовка
.RecordLength = bufHdr.RecordLength ' Длина записи
.NumberFields = (hDbf.HeaderLength - 33) / 32 ' Число полей
.FileSize = 1 + .HeaderLength + .RecordLength * .RecordCount ' Длина файла
' Проверка версии
If .VersionNumber <> 3 Then
dbfReadHeader = -1 ' Это не DBase Файл
Exit Function
End If
' Проверка числа записей
If .RecordCount = 0 Then
dbfReadHeader = -2 ' Нет записей
Exit Function
End If
' Меняем в заголовке число полей
ReDim .Fields(.NumberFields - 1)
' Выделяем память для данных 1 записи
ReDim .Record.Data(.NumberFields - 1)
End With
' Нет ошибок
dbfReadHeader = 0
End Function
'==============================================================
' Цель. Прочитать данные из заголовка
' о полях: Имя, Тип, Длина, Дес. точка
'
Function dbfReadNameFields(hDbf As dbfHeader) As Long
Dim i As Long, buf As String, hEof As String
With hDbf
Seek #.DBF, 33 ' Устанавливаем позицию
buf = Space$(32) ' Выделяем память
For i = 0 To .NumberFields - 1
Get #.DBF, , buf ' Читаем строку длиной 32 байта
.Fields(i).Name = Trim(dbfTrimString(Left$(buf, 11), 11))
.Fields(i).Type = Mid$(buf, 12, 1)
.Fields(i).Length = Asc(Mid$(buf, 17, 1))
.Fields(i).Dec = Asc(Mid$(buf, 18, 1))
Next i
hEof = Input$(1, #.DBF) ' Конец заголовка
If Asc(hEof) <> 13 Then
dbfReadNameFields = False ' Плохой заголовок
Else
dbfReadNameFields = True ' Правильная структура
End If
End With
End Function
'==============================================================
' Сохраняем данные о полях в таблице
'
Function dbfSaveNameFields(hDbf As dbfHeader) As Long
Dim i As Long, s As String
Dim dbs As DAO.Database, tdf As DAO.TableDef
With hDbf
' Удаляем ненужную таблицу
On Error Resume Next
DoCmd.DeleteObject acTable, .TableAccess
Err.Clear
' Создаем поля
Set dbs = CurrentDb
Set tdf = dbs.CreateTableDef(.TableAccess) 'Создаем таблицу
For i = 0 To .NumberFields - 1
s = .Fields(i).Name
Select Case .Fields(i).Type
'Для Clipper и длине более 256 поле представляем как М
Case "C": tdf.Fields.Append IIf(hDbf.Fields(i).Dec = 0, tdf.CreateField(s, dbText, hDbf.Fields(i).Length), tdf.CreateField(s, dbMemo))
Case "D": tdf.Fields.Append tdf.CreateField(s, dbDate)
Case "F": tdf.Fields.Append tdf.CreateField(s, dbFloat)
Case "M": tdf.Fields.Append tdf.CreateField(s, dbMemo)
Case "L": tdf.Fields.Append tdf.CreateField(s, dbBoolean)
Case "N": tdf.Fields.Append tdf.CreateField(s, dbDouble)
End Select
Next i
End With
dbs.TableDefs.Append tdf 'Добавляем таблицу
End Function
'==============================================================
' Прочитаем 1 запись в базу данных
'
Sub dbfReadRecord(hDbf As dbfHeader, NumRec As Long)
Dim buf As String, pos As Long, i As Long
Dim ss As String, p As Long
With hDbf
' Выделяем память
buf = Space$(.RecordLength)
' Находим позицию
Seek #.DBF, 1 + .HeaderLength + (NumRec - 1) * .RecordLength
' Читаем запись
Get #.DBF, , buf
' Чтение метки удаления "*" и " "
.Record.Mark = Left(buf, 1)
' Установка позиции
pos = 2
' Разбор данных
For i = 0 To .NumberFields - 1
' Выбор полей
ss = Mid(buf, pos, .Fields(i).Length)
ss = dbfTrimString(ss, CLng(.Fields(i).Length))
' Настройка некоторых полей
Select Case hDbf.Fields(i).Type
'Для Clipper и длине более 256 корректируем дляну и заново пересчитываем данные из файла
Case "C"
If hDbf.Fields(i).Dec <> 0 Then
ss = Mid(buf, pos, 256 * .Fields(i).Dec + .Fields(i).Length)
ss = dbfTrimString(ss, CLng(256 * .Fields(i).Dec + .Fields(i).Length))
End If
Case "D" ' dd/mm/yyyy
ss = Right$(ss, 2) + "/" + Mid$(ss, 5, 2) + "/" + Left$(ss, 4)
Case "L" ' Логическое поле T,Y или F,N
Select Case UCase$(ss)
Case "Y", "T": ss = "True"
Case "N", "F": ss = "False"
Case Else: ss = "?"
End Select
Case Else
End Select
' Назначаем данные
.Record.Data(i) = ss
' Определяем позицию следующего поля
pos = pos + .Fields(i).Length
Next i
End With
End Sub
'==============================================================
' Сохраняем данные 1 записи в таблице
'
Function dbfSaveRecord(hDbf As dbfHeader) As Long
Dim i As Long, p As Long, dbs As Database, rst As DAO.Recordset, buf As String, sn As String
On Error GoTo 999
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(hDbf.TableAccess)
With hDbf
rst.AddNew
For i = 0 To .NumberFields - 1
buf = .Record.Data(i) ' Nz(Trim(.Record.Data(i)), " ")
sn = .Fields(i).Name
Select Case .Fields(i).Type
Case "C": rst(sn).Value = CStr(buf)
Case "D": rst(sn).Value = CDate(buf)
Case "M": rst(sn).Value = buf
Case "L": rst(sn).Value = CBool(buf)
Case "N", "F":
p = InStr(buf, ".")
If p Then buf = Left(buf, p - 1) & "," & Mid(buf, p + 1)
rst(sn).Value = CDbl(buf)
End Select
Next i
rst.Update
End With
rst.Close
Set rst = Nothing
Set dbs = Nothing
Exit Function
999:
Err.Clear
Resume Next
End Function
'==============================================================
' Программа для конвертации строки из Dos в Windows и наоборот
'
Public Function dbfReadDate(buf As String) As Date
On Error Resume Next
dbfReadDate = DateValue( _
1900 + Asc(Mid$(buf, 1, 1)) & "/" & _
Asc(Mid$(buf, 2, 1)) & "/" & _
Asc(Mid$(buf, 3, 1)))
Err.Clear
End Function
'==============================================================
' Программа для конвертации строки из Dos в Windows и наоборот
'
Public Function dbfStrConv(strData As String, buf1 As String, buf2 As String) As String
Dim i As Long, strChar As String, p As Long
' Конвертирование строки
dbfStrConv = ""
For i = 1 To Len(strData)
strChar = Mid(strData, i, 1)
p = InStr(1, buf1, strChar)
If p > 0 Then
dbfStrConv = dbfStrConv & Mid(buf2, p, 1)
Else
dbfStrConv = dbfStrConv & strChar
End If
Next
End Function
'==============================================================
' Обрезаем ненужные данные из строки dbf
'
Public Function dbfTrimString(strData As String, lngData As Long) As String
Dim p1 As Long, p2 As Long
' Конвертируем строку из Dos в Windows
strData = dbfStrConv(strData, alfaDos, alfaWin)
' Определяем пустые данные
For p1 = 1 To lngData
If Asc(Mid(strData, p1, 1)) >= 32 Then Exit For
Next
For p2 = p1 To lngData
If Asc(Mid(strData, p2, 1)) < 32 Then Exit For
Next
dbfTrimString = Mid(strData, p1, p2 - p1)
End Function
'<--End |