Программирование на Visual Basic

Формат DBase - это, наверное, самый популярный формат хранения данных в базах данных на заре развития компьютерных технологий. Таким образом, зная этот формат Вы сможете загрузить в базу данных Access данные из dbf напрямую, минуя драйвер. Для загрузки DOS символов применяется программа перекодировщик.

'Const alfaAnsi As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ^abcdefghijklmnopqrstuvwxyz~"
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
            Case "C":  tdf.Fields.Append tdf.CreateField(s, dbText, hDbf.Fields(i).Length)
            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)
    '            If .Fields(i).Dec = 0 Then
    '                tdf.Fields.Append tdf.CreateField(s, dbLong)
    '            Else
    '            End If
            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
              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