VERSION 1.0 CLASS
BEGIN
  MultiUse = -1 'True
  Persistable = 0 'NotPersistable
  ataBindingBehavior = 0 'vbNone
  ataSourceBehavior = 0 'vbNone
  MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsDBF"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Text
Option Explicit

'Модуль предназначен для работы с DBF файлами (чтение/редактирование/
' создание/сжатие) средствами VB/VBA и Win API.
'Работает в среде VB5/6, Access 97/2000/2002 и других приложениях Office.
'Версия 2.3 Февраль 2004 г.
'Разработал Кривцов Анатолий, г.Киев, Украина.

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Const conDBFType_SimpleNoMemo As Long = &H3 'No memo

Private Type DBFHeader
    Type As Byte '0 Тип БД
    at(0 To 2) As Byte '1-3 Дата обновления YYMMDD
    RecordCount As Long '4-7 Кол-во записей, включая удаленные
    Offset As Integer '8-9 Смещение 1-й записи
    RecordLength(0 To 3) As Byte '10-13 Длина записи (12,13 - резервные)
    res(0 To 13) As Byte '14-27
    Flag As Byte '28 Флаги для FP(02-есть Memo поля)
    CodePage As Byte '29 Кодовая страница в FP
    res2(0 To 1) As Byte '30-31
End Type

Private Type DBFField
    FieldName(0 To 10) As Byte '0-10 Имя поля (массив байтов)
    Type As Byte '11 Тип поля: "C", "N", "" и т.д.
    Offset As Long '12-15 Смещение поля в записи (не всегда)
    Length As Byte '16 Длина поля
    ecimalPlaces As Byte '17 Число десятичных символов
    flags As Byte '18 2-разрешен Null, 4-двоичное
    res(0 To 12) As Byte '19-32
End Type

Private Type DBFFieldExt
    FieldName As String 'Имя поля (строка ANSI)
    TypeDBF As Byte 'Тип поля (модифицированный)
    TypeDAO As Long 'Тип поля (соответствует DAO константам)
    Offset As Long 'Реальное смещение поля в записи
    Size As Long 'Реальная длина поля
    Binary As Boolean 'Данные в двоичном виде ("С" и "М" в FP30)
End Type

Private lngCharset As Long 'Кодировка символов в DBF

Private hFile As Integer 'Дискриптор файла
Private hMemoFile As Integer 'Дискриптор MEMO файла
Private Head As DBFHeader 'Заголовок
Private DBFFields() As DBFField 'Свойства полей
Private DBFFieldsExt() As DBFFieldExt 'Свойства полей для VBA
Private lngRecordLen As Long 'Длина записи
Private lngFieldsCount As Long 'Количество полей
Private CurRec As Long 'Текущая запись (смещение)

Private CurData() As Byte 'Данные считанной записи
Private BuffData() As Byte 'Буфер данных записи

Private strDBFFullPath As String 'Путь к DBF файлу
Private strMemoFullPath As String 'Путь к DBT (FPT) файлу (MEMO поля)
Private strFolder As String 'Путь к папке

Private fNewFile As Boolean 'Создается новый файл
Private fRO As Boolean 'Файл открыт только для чтения
Private bytRecordMode As Byte '1-редактируется, 2-новая
Private strError As String 'Сообщение об ошибках

'======= Типы полей ==================================
Private Const conFieldTypeString As Byte = 67 '"C"
Private Const conFieldTypeNumeric As Byte = 78 '"N"
Private Const conFieldTypeDate As Byte = 68 '""
Private Const conFieldTypeLogical As Byte = 76 '"L"
Private Const conFieldTypeMemo As Byte = 77 '"M"
Private Const conFieldTypeGeneral As Byte = 71 '"G"
Private Const conFieldTypeFloat As Byte = 70 '"F"
'Для Visual FoxPro (ver 3.0)
Private Const conFieldTypeLong As Byte = 73 '"I"
Private Const conFieldTypeDouble As Byte = 66 '"B"
Private Const conFieldTypeCurrency As Byte = 89 '"Y"
Private Const conFieldTypeDateTime As Byte = 84 '"T"
'Для спец. файла импорта/экспорта
Private Const conFieldTypeByte As Byte = 49 '"1"
Private Const conFieldTypeInteger As Byte = 50 '"2"
Private Const conFieldTypeSingle As Byte = 52 '"4"
Private Const conFieldTypeVariant As Byte = 86 '"V"
'----------------------------------------------------
Private Const daoTypeBoolean As Integer = 1 'dbBoolean
Private Const daoTypeByte As Integer = 2 'dbByte
Private Const daoTypeInteger As Integer = 3 'dbInteger
Private Const daoTypeLong As Integer = 4 'dbLong
Private Const daoTypeCurrency As Integer = 5 'dbCurrency
Private Const daoTypeSingle As Integer = 6 'dbSingle
Private Const daoTypeDouble As Integer = 7 'dbDouble
Private Const daoTypeDate As Integer = 8 'dbDate
Private Const daoTypeText As Integer = 10 'dbText
Private Const daoTypeLongBinary As Integer = 11 'dbLongBinary
Private Const daoTypeMemo As Integer = 12 'dbMemo
Private Const daoTypeDecimal As Integer = 20 'dbDecimal
'Для неопознанного типа поля
Private Const daoTypeBinary As Integer = 9 'dbBinary

'----------------------------------------------------
Private Const conDeleteMark As Byte = 42 '"*"
Private Const conHeaderTerminator As Byte = &HD
Private Const conFileTerminator As Byte = &H1A

Private Const conDateOffset As Long = &H24D9AB

Public Function OpenFile(strFilePath As String, _
        Optional ByVal lngCharsetForString As Long, _
        Optional ByVal fReadOnly As Boolean) As Boolean
On Error GoTo OpenFile_err
Dim i As Long
    
    strDBFFullPath = Trim$(strFilePath)
 If Len(strDBFFullPath) = 0 Then
    MsgBox "Не указан путь к файлу!", vbExclamation
    Exit Function
 End If
 If Not CheckFileExists(strDBFFullPath, strFolder) Then
    MsgBox "Файл " & strDBFFullPath & " не найден!", vbExclamation
    Exit Function
 End If
 If Not fReadOnly Then
    fRO = (GetAttr(strDBFFullPath) And vbReadOnly)
  If fRO Then
   If MsgBox("Файл " & strDBFFullPath & " имеет атрибут ""Только для" _
        & " чтения""" & vbCrLf & vbCrLf & "Продолжать?", _
        vbQuestion + vbOKCancel) = vbCancel Then
    Exit Function
   End If
  End If
 Else
    fRO = True
 End If
     
 If hFile <> 0 Then Close #hFile
    
    hFile = FreeFile
 If fRO Then
    Open strDBFFullPath For Binary Access Read As hFile
 Else
    Open strDBFFullPath For Binary Access Read Write As hFile
 End If
    Get hFile, , Head
 
 Select Case GetFileType
  Case 0
    MsgBox "Тип файла " & strFilePath & " не опознан!", vbExclamation
    Close #hFile
    hFile = 0
    Exit Function
  Case xDBFType_FoxPro30
' Число полей в Visual FoxPro
    lngFieldsCount = (Head.Offset - 296) / 32
  Case Else
' Число полей в DbaseIII-V, FoxBase, FoxPro2.x
    lngFieldsCount = (Head.Offset - 33) / 32
 End Select
    
    ReDim DBFFields(0 To lngFieldsCount - 1)
 For i = 0 To lngFieldsCount - 1
    Get hFile, , DBFFields(i)
 Next i
    Get hFile, , bytRecordMode
 If bytRecordMode <> 13 Then
    MsgBox "Файл " & strFilePath _
                & " имеет неправильную структуру!", vbExclamation
    Close #hFile
    hFile = 0
    Exit Function
 End If
    bytRecordMode = 0
    
    lngCharset = lngCharsetForString
 Select Case lngCharsetForString
  Case xDBFCharsetDOS866
  Case xDBFCharsetUkrStandard
  Case xDBFCharsetANSI
  Case Else
        lngCharset = xDBFCharsetDOS866
   Select Case Head.Type
    Case xDBFType_ImpExpSpec
        lngCharset = xDBFCharsetANSI
    Case xDBFType_FoxPro30
     If (Head.CodePage And 3) = 3 Then
        lngCharset = xDBFCharsetANSI
     End If
   End Select
 End Select
 If Head.Type = xDBFType_ImpExpSpec Then
    lngRecordLen = GetLong(Head.RecordLength)
 Else
    lngRecordLen = GetInteger(Head.RecordLength)
 End If
'На основе сведений о полях создается список дополнительных свойств,
' и проверяется структура файла.
'Если структура неправильная (размеры полей, длина записи) - прерывается.
 If Not CheckFieldsStruct Then
    Close #hFile
    hFile = 0
    Exit Function
 End If
'Буфер для данных записи
    ReDim CurData(0 To lngRecordLen - 1)
    Call MoveFirst
    
    OpenFile = True

OpenFile_exit:
    Exit Function
OpenFile_err:
    MsgBox Err.Description, vbCritical
    Resume OpenFile_exit
End Function

Public Function CreateNewFile(strFilePath As String, _
    Optional ByVal lngFileType As Long = conDBFType_SimpleNoMemo, _
    Optional ByVal lngCharsetForString As Long, _
    Optional fOverwriteExists As Boolean) As Boolean
'Создает в буфере заголовок нового файла.
'strFilePath - путь к файлу;
'lngFileType - тип файла (одна из констант xDBFType...);
'lngCharsetForString - кодировка символов (одна из констант xDBFCharset...);
'fOverwriteExists - переписывает существующий файл молча или
' спрашивает разрешения.
On Error GoTo CreateNewFile_err

 If hFile <> 0 Then Close #hFile
 If hMemoFile <> 0 Then Close #hMemoFile
 If Head.Type > 0 Then
        strDBFFullPath = String(16, vbNullChar)
        CopyMemory Head, ByVal strDBFFullPath, 32
 End If
    Call CloseFile
    
    fRO = False
    strDBFFullPath = Trim$(strFilePath)
 If Len(strDBFFullPath) = 0 Then
        MsgBox "Не указан путь к файлу!", vbExclamation
        Exit Function
 End If
    
    Head.Type = lngFileType
 If GetFileType = 0 Then
        MsgBox "Указан неизвестный тип DBF файла!", vbExclamation
        strDBFFullPath = vbNullString
        Exit Function
 End If
 
 If CheckFileExists(strDBFFullPath, strFolder) Then
  If Not fOverwriteExists Then
   If MsgBox("Файл " & strDBFFullPath & " существует!" _
            & vbCrLf & vbCrLf & "Удалить его?", vbQuestion + _
            vbOKCancel + vbDefaultButton2) = vbCancel Then
        strDBFFullPath = vbNullString
        Exit Function
   End If
  End If
        Kill strDBFFullPath
 End If
 
 Select Case Head.Type
  Case xDBFType_FoxPro2x, xDBFType_FoxPro30
        strMemoFullPath = ChangeFileExtention(strDBFFullPath, "fpt"
  Case Else
        strMemoFullPath = ChangeFileExtention(strDBFFullPath, "dbt"
 End Select
 If CheckFileExists(strMemoFullPath) Then
        Kill strMemoFullPath
 End If
        strMemoFullPath = vbNullString
        
        lngCharset = lngCharsetForString
 Select Case lngCharsetForString
  Case xDBFCharsetDOS866
  Case xDBFCharsetUkrStandard
  Case xDBFCharsetANSI
  Case Else
   If Head.Type = xDBFType_ImpExpSpec Then
        lngCharset = xDBFCharsetANSI
   Else
        lngCharset = xDBFCharsetDOS866
   End If
 End Select
    
    lngRecordLen = 1
    Head.RecordLength(0) = 1
 If Head.Type = xDBFType_FoxPro30 Then
    Head.Offset = 296
 Else
    Head.Offset = 33
 End If
    
    fNewFile = True
    CreateNewFile = True

CreateNewFile_exit:
    Exit Function
CreateNewFile_err:
    MsgBox Err.Description, vbCritical
    Resume CreateNewFile_exit
End Function

Function SaveNewFile() As Boolean
'Сохраняет на диске файл с ранее созданным заголовком и структурой полей.
'Выполняется автоматически при вызове метода AddNew.
On Error GoTo SaveNewFile_err
Dim bytArr() As Byte
    
 If Len(strDBFFullPath) = 0 Then
    MsgBox "Новый файл еще не создан!", vbExclamation
    Exit Function
 End If
 If lngFieldsCount = 0 Then
    MsgBox "В файле еще нет полей!", vbExclamation
    Exit Function
 End If
 Select Case Head.Type
  Case xDBFType_ImpExpSpec
  Case xDBFType_FoxPro30
   If Len(strMemoFullPath) > 0 Then
        Head.Flag = (Head.Flag Or 2)
   End If
  Case Else
   If Len(strMemoFullPath) = 0 Then
        Head.Type = conDBFType_SimpleNoMemo
   End If
 End Select
    hFile = FreeFile
    Open strDBFFullPath For Binary Access Read Write As hFile
          
    ReDim bytArr(0 To Head.Offset)
    Put hFile, 1, bytArr
    Put hFile, 1, Head 'Записываем заголовок
    Put hFile, , DBFFields
    Put hFile, , conHeaderTerminator
    Put hFile, Head.Offset + 1, conFileTerminator

    Erase bytArr
    fNewFile = False
    SaveNewFile = True

SaveNewFile_exit:
    Exit Function

SaveNewFile_err:
    Close hFile
    hFile = 0
    MsgBox Err.Description, vbCritical
    Resume SaveNewFile_exit
End Function

Private Function CheckNewFieldName(strFieldName As String, _
                                        bytArr() As Byte) As Boolean
Dim lngNameLen As Long, strFieldNameExt As String
    
    strFieldName = Trim$(strFieldName)
    lngNameLen = Len(strFieldName)
 Select Case lngNameLen
  Case 0
    MsgBox "Не указано имя поля!", vbExclamation
    Exit Function
  Case Is > 10
   If Head.Type = xDBFType_ImpExpSpec Then
    If lngNameLen > 28 Then
        MsgBox "Имя поля в файле ImpExpSpec не может превышать" _
            & " 28 символов!", vbExclamation
        Exit Function
    End If
   Else
        MsgBox "Имя поля не может превышать 10 символов!", vbExclamation
        Exit Function
   End If
 End Select
 If CheckNumField(strFieldName, fNoMsgNotFound:=True) >= 0 Then
    MsgBox "Поле " & strFieldName & " уже существует!", vbExclamation
    Exit Function
 End If
 Select Case lngCharset
  Case xDBFCharsetANSI
    strFieldNameExt = strFieldName
  Case xDBFCharsetUkrStandard
    strFieldNameExt = ConvANSItoDOS(strFieldName, fUkrStandard:=True)
  Case Else
    strFieldNameExt = ConvANSItoDOS(strFieldName)
 End Select
 If Head.Type = xDBFType_ImpExpSpec Then
  If lngNameLen < 28 Then
    strFieldNameExt = strFieldNameExt & String(28 - lngNameLen, vbNullChar)
  End If
 Else
    strFieldNameExt = strFieldNameExt & Space(11 - lngNameLen)
 End If
    bytArr() = StrConv(strFieldNameExt, vbFromUnicode)

    CheckNewFieldName = True
End Function

Private Function AppendField(ByVal strFieldName As String, _
                        ByVal lngFieldSize As Long) As Long
Dim lngFieldNum As Long, lngTemp As Long
Dim bytArr() As Byte

    AppendField = -1
 If Not CheckNewFieldName(strFieldName, bytArr) Then Exit Function
    
    lngFieldNum = lngFieldsCount
    lngTemp = MaxRecordLength - lngRecordLen
 If lngTemp < lngFieldSize Then
    MsgBox "Создание поля с размером " & lngFieldSize & " байтов" _
        & " невозможно из-за превышения максимальной длины записи!" _
        & IIf(lngTemp = 0, vbNullString, vbCrLf & vbCrLf _
        & "Максимальный доступный размер - " & lngTemp _
        & " байтов.", vbExclamation
    Exit Function
 End If
 
    ReDim Preserve DBFFieldsExt(0 To lngFieldNum)
 With DBFFieldsExt(lngFieldNum)
    .FieldName = strFieldName
    .Size = lngFieldSize
  If lngFieldNum = 0 Then
    .Offset = 1
  Else
    .Offset = DBFFieldsExt(lngFieldNum - 1).Offset + _
        BFFieldsExt(lngFieldNum - 1).Size
  End If
 End With
    
    ReDim Preserve DBFFields(0 To lngFieldNum)
 With DBFFields(lngFieldNum)
    CopyMemory .FieldName(0), bytArr(0), 11 'GetArraySize(bytArr)
  If Head.Type = xDBFType_ImpExpSpec Then
    CopyMemory .Offset, bytArr(11), 4
    CopyMemory .res(0), bytArr(15), 13
  End If
  If lngFieldSize > 255 Then
    .Length = lngFieldSize Mod 256
    .DecimalPlaces = (lngFieldSize - .Length) / 256
  Else
    .Length = lngFieldSize
  End If
 End With
    lngRecordLen = lngRecordLen + lngFieldSize
 With Head
    .Offset = .Offset + 32
  If Head.Type = xDBFType_ImpExpSpec Then
    CopyMemory .RecordLength(0), lngRecordLen, 4
  Else
    CopyMemory .RecordLength(0), lngRecordLen, 2
  End If
 End With
    lngFieldsCount = lngFieldsCount + 1
    AppendField = lngFieldNum
End Function

Public Function CreateField(strFieldName As String, _
                Optional ByVal intTypeDAO As Integer, _
                Optional ByVal varTypeOriginal As Variant = 0, _
                Optional ByVal lngFieldSize As Long, _
                Optional ByVal intDecPlaces As Integer = -1, _
                Optional fBynaryData As Boolean, _
                Optional fNotCheckTextSize As Boolean) As Long
'Создает новое поле. Тип и свойства определяются значениями аргументов
' intTypeDAO (тип поля в DAO) или varTypeOriginal (тип поля в DBF).
'В varTypeOriginal может прописная или строчная буква, представляющая
' тип поля, ANSI код такого символа или слово, начинающееся с правильного
' символа. Например, эквивалентны: "N", "n", 78, 110, "Numeric"
'Один из этих аргументов может быть пропущен. Если указаны оба, то для
' формата xDBFType_ImpExpSpec bytTypeOriginal игнорируется. Для других
' форматов bytTypeOriginal является основным. Если он указан, то
' intTypeDAO может использоваться только при конвертировании файла из
' формата dBaseV в FoxPro3.x (и наоборот), если указан тип поля "В"
' (ANSI код = 66), имеющий различное трактование.
'lngFieldSize - размер поля. Используется для текстовых полей, и
' числовых полей типа Numeric (текстовое представление числа).
'intDecPlaces - количество знаков после запятой для числовых полей
' типа Numeric (текстовое представление числа);
' - можно указать значение Precision для полей типа
' dbDecimal, а затем использовать при создании таблицы.
'fNotCheckTextSize - разрешает создание текстовых полей длиной
' более 255 символов.
'fBynaryData - для текстового и MEMO поля указывает, что данные - двоичные.
'Возвращает номер поля или -1, если ошибка.
Dim bytTypeOriginal As Byte
Dim lngFieldPos As Long, intNumericType As Integer
Const conMsgHeader = "Создание поля"
    
    CreateField = -1
 If Not fNewFile Then
  If Head.RecordCount > 0 Then
    MsgBox "Добавление поля возможно только в новый файл, или" _
        & " в существующий, не имеющий ни одной записи!", vbCritical
    Exit Function
  End If
  If Not AllowModify Then Exit Function
 End If
 If VarType(varTypeOriginal) = vbString Then
        bytTypeOriginal = Asc(UCase(varTypeOriginal))
 ElseIf IsNumeric(varTypeOriginal) Then
  Select Case CLng(varTypeOriginal)
   Case Is < 32
   Case Is > 127
   Case 97 To 122
        bytTypeOriginal = CByte(varTypeOriginal) - 32
   Case Else
        bytTypeOriginal = CByte(varTypeOriginal)
  End Select
 End If
 If intTypeDAO = 0 And bytTypeOriginal = 0 Then
    MsgBox "Не указан, или неправильно указан тип поля!", _
                vbExclamation, conMsgHeader
    Exit Function
 End If
 If intTypeDAO <> 0 And (bytTypeOriginal = 0 Or _
                    Head.Type = xDBFType_ImpExpSpec) Then
    GoTo CreateByDAO
 End If
 
 Select Case bytTypeOriginal
  Case conFieldTypeString
    lngFieldPos = CreateTextField(strFieldName, lngFieldSize, _
                                fBynaryData, fNotCheckTextSize)
    intTypeDAO = daoTypeText
  Case conFieldTypeNumeric, conFieldTypeFloat
    lngFieldPos = CreateNumericField(strFieldName, , lngFieldSize, intDecPlaces)
    intTypeDAO = daoTypeDouble
   If bytTypeOriginal = conFieldTypeFloat And lngFieldPos >= 0 Then
        BFFields(lngFieldPos).Type = conFieldTypeFloat
   End If
  Case conFieldTypeDate, conFieldTypeDateTime
    lngFieldPos = CreateDateField(strFieldName)
    intTypeDAO = daoTypeDate
  Case conFieldTypeLogical
    lngFieldPos = CreateLogicalField(strFieldName)
    intTypeDAO = daoTypeBoolean
  Case conFieldTypeMemo, conFieldTypeGeneral, 80 '"P"
    lngFieldPos = CreateMemoField(strFieldName, fBynaryData)
   If fBynaryData Then
    intTypeDAO = daoTypeLongBinary
   Else
    intTypeDAO = daoTypeMemo
   End If
  Case 66 '"B"
   If intTypeDAO = daoTypeLongBinary Then
    lngFieldPos = CreateMemoField(strFieldName, True)
   Else
    intNumericType = daoTypeDouble
   End If
  Case conFieldTypeDouble: intNumericType = daoTypeDouble
  Case conFieldTypeLong: intNumericType = daoTypeLong
  Case conFieldTypeCurrency: intNumericType = daoTypeCurrency
  Case conFieldTypeInteger: intNumericType = daoTypeInteger
  Case conFieldTypeByte: intNumericType = daoTypeByte
  Case conFieldTypeSingle: intNumericType = daoTypeSingle
  Case conFieldTypeVariant: intNumericType = daoTypeDecimal
  Case Else 'Неизвестный тип поля
   If lngFieldSize <= 0 Then Exit Function
   If MsgBox("Тип поля """ & Chr(bytTypeOriginal) & """" _
            & Hex(bytTypeOriginal) & " не опознан!" & vbCrLf & vbCrLf _
            & "Создать двоичное поле с размером " & lngFieldSize _
            & " байтов?", vbQuestion + vbYesNo + vbDefaultButton2, _
            conMsgHeader) = vbNo Then
        Exit Function
   End If
        
        lngFieldPos = AppendField(strFieldName, lngFieldSize)
   If lngFieldPos >= 0 Then
        BFFields(lngFieldPos).Type = bytTypeOriginal
        BFFields(lngFieldPos).DecimalPlaces = intDecPlaces
        BFFieldsExt(lngFieldPos).TypeDBF = bytTypeOriginal
        BFFieldsExt(lngFieldPos).TypeDAO = daoTypeBinary
   End If
        CreateField = lngFieldPos
        Exit Function
 End Select
 If intNumericType > 0 Then
    lngFieldPos = CreateNumericField(strFieldName, intNumericType)
    intTypeDAO = intNumericType
 End If
 If lngFieldPos >= 0 Then
  With DBFFields(lngFieldPos)
   If .Type = 0 Then .Type = bytTypeOriginal
  End With
 End If
    GoTo Finish
'--------------------------------------------------------------
CreateByDAO:
 Select Case intTypeDAO
  Case daoTypeText
    lngFieldPos = CreateTextField(strFieldName, lngFieldSize, _
                            fBynaryData, fNotCheckTextSize)
  Case daoTypeDate
    lngFieldPos = CreateDateField(strFieldName)
  Case daoTypeBoolean
    lngFieldPos = CreateLogicalField(strFieldName)
  Case daoTypeMemo
    lngFieldPos = CreateMemoField(strFieldName, fBynaryData)
  Case daoTypeLongBinary
    lngFieldPos = CreateMemoField(strFieldName, True)
  Case daoTypeDouble, daoTypeLong, daoTypeCurrency, daoTypeInteger, _
            daoTypeSingle, daoTypeByte, daoTypeDecimal
    lngFieldPos = CreateNumericField(strFieldName, intTypeDAO, _
                                lngFieldSize, intDecPlaces)
  Case Else
    MsgBox "Тип поля не опознан!", vbCritical, conMsgHeader
    Exit Function
 End Select

Finish:
 If lngFieldPos >= 0 Then
  If Not CheckFieldsStruct(True) Then Exit Function
 End If
    CreateField = lngFieldPos
End Function

Public Function CreateFieldFromADO(strFieldName As String, _
                Optional ByVal intTypeADO As Integer, _
                Optional ByVal lngFieldSize As Long, _
                Optional ByVal intDecPlaces As Integer = -1, _
                Optional fBynaryData As Boolean, _
                Optional fNotCheckTextSize As Boolean) As Long
'Создает поле с типом, соответствующим типу данных в среде ADO.
'Преобразует значение ADO константы в соотв. с типом в DAO, и
' вызывает функцию CreateField.
Dim i As Integer

 Select Case DBFFieldsExt(intTypeADO).TypeDAO
  Case 130: i = daoTypeText 'adVarWChar
  Case 5: i = daoTypeDouble 'adDouble
  Case 7: i = daoTypeDate 'adDate
  Case 11: i = daoTypeBoolean 'adBoolean
  Case 201: i = daoTypeMemo 'adLongVarWChar
  Case 3: i = daoTypeLong 'adInteger
  Case 2: i = daoTypeInteger 'adSmallInt
  Case 17: i = daoTypeByte 'adUnsignedTinyInt
  Case 6: i = daoTypeCurrency 'adCurrency
  Case 4: i = daoTypeSingle 'adSingle
  Case 205: i = daoTypeLongBinary 'adLongVarBinary
  Case 128: i = daoTypeBinary 'adBinary
  Case Else: i = -1
 End Select
    CreateFieldFromADO = CreateField(strFieldName, i, 0, _
        lngFieldSize, intDecPlaces, fBynaryData, fNotCheckTextSize)
End Function

Private Function CreateTextField(strFieldName As String, _
                    Optional ByVal lngFieldSize As Long = 50, _
                    Optional fBynaryData As Boolean, _
                    Optional fNotCheckSize As Boolean) As Long
'В новом файле создает текстовое поле с размером в lngFieldSize.
'Если указан fBynaryData - для хранения двоичных данных.
'Если установлен fNotCheckSize, или создается ImpExpSpec файл, -
' размер поля может достигать 65535 байтов. Иначе - 254 байта, при этом
' значение 255 усекается до 254, а при большем - выдается ошибка.
'Возвращает номер поля или -1, если ошибка.
Dim lngFieldPos As Long

    CreateTextField = -1
 Select Case lngFieldSize
  Case Is <= 0
        lngFieldSize = 50
  Case Is > 254
   If Head.Type = xDBFType_ImpExpSpec Or fNotCheckSize Then
   Else
    If lngFieldSize = 255 Then
        lngFieldSize = 254
    Else
        MsgBox "Размер поля не может превышать 254 байта!", vbExclamation
        Exit Function
    End If
   End If
 End Select
    lngFieldPos = AppendField(strFieldName, lngFieldSize)
 If lngFieldPos < 0 Then Exit Function
 With DBFFields(lngFieldPos)
    .Type = conFieldTypeString
  If fBynaryData Then .flags = .flags Or 4
 End With
 With DBFFieldsExt(lngFieldPos)
    .TypeDBF = conFieldTypeString
  If fBynaryData Then .Binary = True
  If .Size > 255 Then
    .TypeDAO = daoTypeMemo
  Else
    .TypeDAO = daoTypeText
  End If
 End With
    CreateTextField = lngFieldPos
End Function

Private Function CreateNumericField(strFieldName As String, _
        Optional ByVal intFieldTypeDAO As Integer, _
        Optional ByVal intFieldSize As Integer, _
        Optional ByVal intDecimalPlaces As Integer = -1) As Long
'В новом файле создает числовое поле, тип и размер которого зависит
' от типа файла и необязательных аргументов:
' intFieldTypeDAO - тип поля в Access и библиотеке DAO;
' intFieldSize - длина поля в текстовом представлении ("N" - Numeric);
' intDecimalPlaces - количество десятичных символов.
'В форматах xDBFType_ImpExpSpec или xDBFType_FoxPro30 тип поля
' зависит от аргумента intFieldTypeDAO, и если аргумент не указан
' (или указаны dbNumeric) - создает поле с текстовым представлением
' числа ("N" по методике, описанной ниже. Это поле требует больше
' ресурсов, но может хранить также значения Null.
'В формате xDBFType_ImpExpSpec, если указан тип dbDecimal
' (daoTypeDecimal), создает поле типа Variant (16 байтов),
' поддерживающее также значения Null и Empty. Структура этого поля
' соответствует структуре переменной Variant, и содержит не только
' значение, но и его тип.
'В формате xDBFType_FoxPro30 типы Single и Decimal конвертируются
' в Double, а типы Byte и Integer - в Long.
'В других форматах создается поле с текстовым представл. числа ("N".
' Параметры поля зависят от комбинации аргументов, из которых
' основным является аргумент intFieldSize.
' Если все аргументы пропущены - создается поле 13.5 (размер - 19 симв.)
' Если указан только intFieldTypeDAO - создается поле с размером и
' числом десятичных знаков, достаточными для хранения чисел данного типа.
' Если intFieldSize указан, то количество десятичных символов определяется
' intDecimalPlaces и/или intFieldTypeDAO (по умолчанию - 5 символов).
'Возвращает номер поля или -1, если ошибка.
Dim lngFieldPos As Long, bytDBFFieldType As Byte, fExpImp As Boolean

        CreateNumericField = -1
        fExpImp = (Head.Type = xDBFType_ImpExpSpec)
        bytDBFFieldType = conFieldTypeNumeric
 
 Select Case Head.Type
  Case xDBFType_ImpExpSpec, xDBFType_FoxPro30
   Select Case intFieldTypeDAO
    Case Is <= 0, 19 '19 - dbNumeric
        GoTo NumericFieldProperties
    Case daoTypeLong
        bytDBFFieldType = conFieldTypeLong
    Case daoTypeDouble
        bytDBFFieldType = conFieldTypeDouble
    Case daoTypeCurrency
        bytDBFFieldType = conFieldTypeCurrency
    Case daoTypeByte
     If fExpImp Then
        bytDBFFieldType = conFieldTypeByte
     Else
        bytDBFFieldType = conFieldTypeLong
        intFieldTypeDAO = daoTypeLong
     End If
    Case daoTypeInteger
     If fExpImp Then
        bytDBFFieldType = conFieldTypeInteger
     Else
        bytDBFFieldType = conFieldTypeLong
        intFieldTypeDAO = daoTypeLong
     End If
    Case daoTypeSingle
     If fExpImp Then
        bytDBFFieldType = conFieldTypeSingle
     Else
        bytDBFFieldType = conFieldTypeDouble
        intFieldTypeDAO = daoTypeDouble
     End If
    Case daoTypeDecimal
     If fExpImp Then
        bytDBFFieldType = conFieldTypeVariant
     Else
        bytDBFFieldType = conFieldTypeDouble
        intFieldTypeDAO = daoTypeDouble
     End If
    Case Else
        GoTo NumericFieldProperties
   End Select
  Case Else
        GoTo NumericFieldProperties
 End Select
 Select Case intFieldTypeDAO
  Case daoTypeLong: intFieldSize = 4
  Case daoTypeDouble: intFieldSize = 8
  Case daoTypeCurrency: intFieldSize = 8
  Case daoTypeInteger: intFieldSize = 2
  Case daoTypeSingle: intFieldSize = 4
  Case daoTypeByte: intFieldSize = 1
  Case daoTypeDecimal: intFieldSize = 16
 End Select
        GoTo CreateFieldStep
    
NumericFieldProperties:
        bytDBFFieldType = conFieldTypeNumeric
 Select Case intFieldSize
  Case Is <= 0
   Select Case intFieldTypeDAO
    Case daoTypeLong
        intFieldSize = 11
    Case daoTypeByte
        intFieldSize = 3
    Case daoTypeInteger
        intFieldSize = 6
    Case Else
        intFieldSize = 19
   End Select
  Case Is >= 20
   Select Case Head.Type
    Case xDBFType_ImpExpSpec
    Case xDBFType_FoxPro2x, xDBFType_FoxPro30
        intFieldSize = 20
    Case Else
        intFieldSize = 19
   End Select
 End Select
 
 Select Case intDecimalPlaces
  Case Is < 0
   Select Case intFieldTypeDAO
    Case daoTypeLong, daoTypeInteger, daoTypeByte
        intDecimalPlaces = 0
    Case daoTypeCurrency
        intDecimalPlaces = 2
    Case Else
        intDecimalPlaces = 5
   End Select
  Case Is > (intFieldSize - 2)
        intDecimalPlaces = intFieldSize - 2
 End Select
 
CreateFieldStep:
    lngFieldPos = AppendField(strFieldName, intFieldSize)
 If lngFieldPos < 0 Then Exit Function
 If intDecimalPlaces < 0 Then intDecimalPlaces = 0
 With DBFFields(lngFieldPos)
    .Type = bytDBFFieldType
    .DecimalPlaces = intDecimalPlaces
 End With
    CreateNumericField = lngFieldPos
End Function

Private Function CreateLogicalField(strFieldName As String) As Long
'Создает логическое поле.
'Возвращает номер поля или -1, если ошибка.
Dim lngFieldPos As Long
    
    lngFieldPos = AppendField(strFieldName, 1)
 If lngFieldPos >= 0 Then
    BFFields(lngFieldPos).Type = conFieldTypeLogical
 End If
    CreateLogicalField = lngFieldPos
End Function

Private Function CreateDateField(strFieldName As String) As Long
'Содает поле типа "Дата" или "Дата/время" в зависимости от формата файла.
'Возвращает номер поля или -1, если ошибка.
Dim lngFieldPos As Long
    
    lngFieldPos = AppendField(strFieldName, 8)
 If lngFieldPos >= 0 Then
  With DBFFields(lngFieldPos)
   Select Case Head.Type
    Case xDBFType_FoxPro30, xDBFType_ImpExpSpec
        .Type = conFieldTypeDateTime
    Case Else
        .Type = conFieldTypeDate
   End Select
  End With
 End If
    CreateDateField = lngFieldPos
End Function

Private Function CreateMemoField(strFieldName As String, _
                    Optional fBynaryData As Boolean) As Long
'Создает MEMO поле.
'Возвращает номер поля или -1, если ошибка.
Dim lngFieldPos As Long
    
    CreateMemoField = -1
 If Head.Type = conDBFType_SimpleNoMemo Then
    MsgBox "При создании файла указан тип, не поддерживающий" _
        & " MEMO полей!", vbExclamation
    Exit Function
 End If
 Select Case Head.Type
  Case xDBFType_FoxPro30, xDBFType_ImpExpSpec
    lngFieldPos = AppendField(strFieldName, 4)
  Case Else
    lngFieldPos = AppendField(strFieldName, 10)
 End Select
 If lngFieldPos < 0 Then Exit Function
 
 With DBFFields(lngFieldPos)
  If fBynaryData Then
        .Type = conFieldTypeGeneral
        .flags = .flags Or 4
        BFFieldsExt(lngFieldPos).Binary = True
  Else
        .Type = conFieldTypeMemo
  End If
 End With
 
 Select Case Head.Type
  Case xDBFType_FoxPro2x, xDBFType_FoxPro30
    strMemoFullPath = ChangeFileExtention(strDBFFullPath, "fpt"
  Case Else
    strMemoFullPath = ChangeFileExtention(strDBFFullPath, "dbt"
 End Select
    CreateMemoField = lngFieldPos
End Function

Public Function GetFileType(Optional strRetTypeName As String) As Byte
 Select Case Head.Type
  Case 3
    strRetTypeName = "FoxBASE+/dBASE III+, no memo"
  Case xDBFType_dBASE_III
    strRetTypeName = "FoxBASE+/dBASE III+ with memo"
  Case xDBFType_dBASE_IV_V
    strRetTypeName = "dBASE IV with memo"
  Case xDBFType_FoxPro2x
    strRetTypeName = "FoxPro 2.x (or earlier) with memo"
  Case xDBFType_FoxPro30
    strRetTypeName = "FoxPro 3.x/Visual FoxPro"
  Case xDBFType_ImpExpSpec
    strRetTypeName = "File Import/Export Special"
  Case 2, &HFB
    strRetTypeName = "FoxBASE"
' &H43 - dBASE IV SQL table files, no memo
' &H63 - dBASE IV SQL system files, no memo
' &HCB - dBASE IV SQL table files, with memo
  Case Else
    Exit Function
 End Select
    GetFileType = Head.Type
End Function

Public Property Get GetCharSet() As Long
    GetCharSet = lngCharset
End Property

Private Function CheckFieldsStruct( _
                    Optional fCreateNewField As Boolean) As Boolean
Dim i As Long, s As String, bytArr() As Byte
Dim lngSize As Long, lngOffset As Long
Const conMsgHeader = "Контроль структуры файла."

        ReDim DBFFieldsExt(0 To lngFieldsCount - 1)
        lngOffset = 1
 For i = 0 To lngFieldsCount - 1
  With DBFFields(i)
        s = GetString(.FieldName)
   If Head.Type = xDBFType_ImpExpSpec Then
'В файлах типа xDBFType_ImpExpSpec имя поля может достигать 28 символов,
' и разделено на 3 части (11 + 4 + 13) символов, которые хранятся в
' отдельных участках описания поля.
    If .Offset <> 0 Then
        ReDim bytArr(0 To 3)
        CopyMemory bytArr(0), .Offset, 4
        s = s & GetString(bytArr)
     If .res(0) > 0 Then
        ReDim bytArr(0 To 12)
        CopyMemory bytArr(0), .res(0), 13
        s = s & GetString(bytArr)
     End If
        Erase bytArr
    End If
   Else
        s = Left(s, 10)
   End If
  End With
        lngSize = InStr(1, s, vbNullChar, vbBinaryCompare)
   If lngSize > 1 Then s = Left$(s, lngSize - 1)
        
        BFFieldsExt(i).FieldName = Trim$(s)
        
        s = vbNullString
        lngSize = DBFFields(i).Length
  
  Select Case DBFFields(i).Type
   Case 66 '"B"
'Если тип "В", то Visual FoxPro это тип "ouble", а для dBaseV -
' "Binary". В этом случае "B" приравнивается к "G" (тип "General".
    If Head.Type = xDBFType_FoxPro30 Then
        BFFieldsExt(i).TypeDBF = conFieldTypeDouble
    Else
        BFFieldsExt(i).TypeDBF = conFieldTypeGeneral
    End If
   
   Case 80
'Если "P" (тип "Picture" - приравнивается к "G" (тип "General".
        BFFieldsExt(i).TypeDBF = conFieldTypeGeneral
   Case Else
        BFFieldsExt(i).TypeDBF = DBFFields(i).Type
  End Select
  
  Select Case DBFFieldsExt(i).TypeDBF
   Case conFieldTypeString
    If DBFFields(i).DecimalPlaces > 0 Then
        lngSize = DBFFields(i).Length + _
                    256 * DBFFields(i).DecimalPlaces
        BFFieldsExt(i).TypeDAO = daoTypeMemo
    Else
        BFFieldsExt(i).TypeDAO = daoTypeText
    End If
    Select Case Head.Type
     Case xDBFType_FoxPro30, xDBFType_ImpExpSpec
      If (DBFFields(i).flags And 4) Then
        BFFieldsExt(i).TypeDAO = daoTypeLongBinary
      End If
    End Select
   Case conFieldTypeMemo, conFieldTypeGeneral
    If DBFFieldsExt(i).TypeDBF = conFieldTypeMemo Then
        BFFieldsExt(i).TypeDAO = daoTypeMemo
     Select Case Head.Type
      Case xDBFType_FoxPro30, xDBFType_ImpExpSpec
       If (DBFFields(i).flags And 4) Then
        BFFieldsExt(i).TypeDAO = daoTypeLongBinary
       End If
     End Select
    Else
        BFFieldsExt(i).TypeDAO = daoTypeLongBinary
    End If
    If Not fCreateNewField Then
     Select Case Head.Type
      Case xDBFType_FoxPro2x, xDBFType_FoxPro30
        strMemoFullPath = ChangeFileExtention(strDBFFullPath, "fpt"
      Case Else
        strMemoFullPath = ChangeFileExtention(strDBFFullPath, "dbt"
     End Select
     If Not CheckFileExists(strMemoFullPath) Then
        strMemoFullPath = vbNullString
     End If
    End If
    Select Case Head.Type
     Case xDBFType_FoxPro30, xDBFType_ImpExpSpec
      If lngSize <> 4 Then
        lngSize = 4
        GoSub FieldErrorMessage
      End If
    End Select
   Case conFieldTypeNumeric, conFieldTypeFloat
    If DBFFields(i).DecimalPlaces = 0 And DBFFields(i).Length <= 9 Then
     If DBFFields(i).Length <= 4 Then
        BFFieldsExt(i).TypeDAO = daoTypeInteger
     Else
        BFFieldsExt(i).TypeDAO = daoTypeLong
     End If
    Else
        BFFieldsExt(i).TypeDAO = daoTypeDouble
    End If
   Case conFieldTypeDate, conFieldTypeDateTime
        BFFieldsExt(i).TypeDAO = daoTypeDate
    If lngSize <> 8 Then
        lngSize = 8
        GoSub FieldErrorMessage
    End If
   Case conFieldTypeLogical
        BFFieldsExt(i).TypeDAO = daoTypeBoolean
    If lngSize <> 1 Then
        lngSize = 1
        GoSub FieldErrorMessage
    End If
   Case conFieldTypeDouble
        BFFieldsExt(i).TypeDAO = daoTypeDouble
    If lngSize <> 8 Then
        lngSize = 8
        GoSub FieldErrorMessage
    End If
   Case conFieldTypeLong
        BFFieldsExt(i).TypeDAO = daoTypeLong
    If lngSize <> 4 Then
        lngSize = 4
        GoSub FieldErrorMessage
    End If
   Case conFieldTypeCurrency
        BFFieldsExt(i).TypeDAO = daoTypeCurrency
    If lngSize <> 8 Then
        lngSize = 8
        GoSub FieldErrorMessage
    End If
   Case conFieldTypeInteger
        BFFieldsExt(i).TypeDAO = daoTypeInteger
    If lngSize <> 2 Then
        lngSize = 2
        GoSub FieldErrorMessage
    End If
   Case conFieldTypeByte
        BFFieldsExt(i).TypeDAO = daoTypeByte
    If lngSize <> 1 Then
        lngSize = 1
        GoSub FieldErrorMessage
    End If
   Case conFieldTypeSingle
        BFFieldsExt(i).TypeDAO = daoTypeSingle
    If lngSize <> 4 Then
        lngSize = 4
        GoSub FieldErrorMessage
    End If
   Case conFieldTypeVariant
        BFFieldsExt(i).TypeDAO = daoTypeDecimal
    If lngSize <> 16 Then
        lngSize = 16
        GoSub FieldErrorMessage
    End If
   Case Else 'Тип поля не опознан
        ErrorAppend = "Тип поля """ & DBFFieldsExt(i).FieldName _
            & """ не опознан! Работать с таким полем можно" _
            & " с помощью байтового массива."
        BFFieldsExt(i).TypeDAO = daoTypeBinary
  End Select
        BFFieldsExt(i).Size = lngSize
        BFFieldsExt(i).Offset = lngOffset
        lngOffset = lngOffset + lngSize
 Next i
 
 If lngRecordLen <> lngOffset Then
    s = "Указанная в заголовке файла длина записи (" _
        & lngRecordLen & " отличается от расчетной (" _
        & lngOffset & " !" & vbCrLf & vbCrLf _
        & "Процедура прервана."
    MsgBox s, vbExclamation, conMsgHeader
    Exit Function
 End If
    CheckFieldsStruct = True
    Exit Function

FieldErrorMessage:
    s = "Для поля " & DBFFieldsExt(i).FieldName & " указан" _
        & " неправильный размер " & DBFFields(i).Length _
        & " байтов." & vbCrLf & vbCrLf & "Требуется " _
        & lngSize & " байтов."
    MsgBox s, vbExclamation, conMsgHeader
    Return
End Function

Public Property Get GetFieldName(ByVal lngFieldNum As Long, _
                    Optional bytRetType As Byte, _
                    Optional bytRetFlags As Byte) As String
'Возвращает имя поля с индексом, указанным в lngFieldNum.
'Для создания другого DBF файла на основе текущего, через аргументы
' передается дополнительная информация:
' bytRetType - тип поля (ANSI код символа "C", "N" ,"" и т.д.);
' bytRetFlags - флаги (в основном - для FoxPro 3.х)
 If CheckNumField(lngFieldNum) < 0 Then Exit Property
 With DBFFields(lngFieldNum)
    bytRetType = .Type
    bytRetFlags = .flags
 End With
    GetFieldName = DBFFieldsExt(lngFieldNum).FieldName
End Property

Public Property Let ChangeFieldName(vIndex As Variant, _
        Optional fNoSave As Boolean, strNewFieldName As String)
'Меняет имя существующего поля, если выполняются требования к длине
' и уникальности нового имени.
'vIndex - имя или номер поля.
'Если указан fNoSave или файл открыт только для чтения, то изменения
' действуют только на время сеанса и не сохраняются в файле.
Dim lngFieldNum As Long, bytArr() As Byte
Dim lngOffset As Long

 If hFile = 0 Then Exit Property
 If Not fNoSave Then
  If Not AllowModify Then Exit Property
 End If
    lngFieldNum = CheckNumField(vIndex)
 If lngFieldNum < 0 Then Exit Property
 If Not CheckNewFieldName(strNewFieldName, bytArr) Then Exit Property

 With DBFFieldsExt(lngFieldNum)
    .FieldName = strNewFieldName
 End With
 With DBFFields(lngFieldNum)
    CopyMemory .FieldName(0), bytArr(0), 11
  If Head.Type = xDBFType_ImpExpSpec Then
    CopyMemory .Offset, bytArr(11), 4
    CopyMemory .res(0), bytArr(15), 13
  End If
 End With
 
 If fRO Or fNoSave Then Exit Property
    lngOffset = Len(Head) + lngFieldNum * 32 + 1
    Put hFile, lngOffset, DBFFields(lngFieldNum)
End Property

Public Property Get GetFieldTypeOriginal(vIndex As Variant) As Byte
'Возвращает тип поля, указанный в файле.
'Это ASCI код символа ("C", "N" и т.д.)
'vIndex - имя или номер поля.
Dim lngFieldNum As Long
    lngFieldNum = CheckNumField(vIndex)
 If lngFieldNum < 0 Then Exit Property
    GetFieldTypeOriginal = DBFFields(lngFieldNum).Type
End Property

Public Property Get GetFieldTypeForDAO(vIndex As Variant) As Long
'Возвращает тип поля, совместимый с DAO.
'vIndex - имя или номер поля.
Dim lngFieldNum As Long
    lngFieldNum = CheckNumField(vIndex)
 If lngFieldNum < 0 Then Exit Property
    GetFieldTypeForDAO = DBFFieldsExt(lngFieldNum).TypeDAO
End Property

Public Property Get GetFieldTypeForADO(vIndex As Variant) As Long
'Возвращает тип поля, совместимый с ADO.
'vIndex - имя или номер поля.
Dim lngFieldNum As Long, L As Long
    lngFieldNum = CheckNumField(vIndex)
 If lngFieldNum < 0 Then Exit Property

 Select Case DBFFieldsExt(lngFieldNum).TypeDAO
  Case daoTypeText: L = 130 'adVarWChar
  Case daoTypeDouble: L = 5 'adDouble
  Case daoTypeDate: L = 7 'adDate
  Case daoTypeBoolean: L = 11 'adBoolean
  Case daoTypeMemo: L = 201 'adLongVarWChar
  Case daoTypeLong: L = 3 'adInteger
  Case daoTypeInteger: L = 2 'adSmallInt
  Case daoTypeByte: L = 17 'adUnsignedTinyInt
  Case daoTypeCurrency: L = 6 'adCurrency
  Case daoTypeSingle: L = 4 'adSingle
  Case daoTypeLongBinary: L = 205 'adLongVarBinary
  Case daoTypeBinary: L = 128 'adBinary
 End Select
    GetFieldTypeForADO = L
End Property

Public Property Get GetFieldSize(vIndex As Variant) As Long
'Возвращает длину поля. Для MEMO полей - длина адреса.
'vIndex - имя или номер поля.
Dim lngFieldNum As Long
    lngFieldNum = CheckNumField(vIndex)
 If lngFieldNum < 0 Then Exit Property
  GetFieldSize = DBFFieldsExt(lngFieldNum).Size
End Property

Public Property Get GetFieldDecPlaces(vIndex As Variant) As Long
'Возвращает количество разрядов дробной части поля типа "Numeric".
'vIndex - имя или номер поля.
Dim lngFieldNum As Long
    
    lngFieldNum = CheckNumField(vIndex)
 If lngFieldNum < 0 Then Exit Property
 If DBFFields(lngFieldNum).Type = conFieldTypeNumeric Then
  GetFieldDecPlaces = DBFFields(lngFieldNum).DecimalPlaces
 End If
End Property

Public Property Get GetFieldIsBinary(vIndex As Variant) As Boolean
'Возвращает True, если текстовое или MEMO поле хранит двоичные данные.
'vIndex - имя или номер поля.
Dim lngFieldNum As Long
    lngFieldNum = CheckNumField(vIndex)
 If lngFieldNum < 0 Then Exit Property
 Select Case DBFFieldsExt(lngFieldNum).TypeDAO
  Case daoTypeBinary, daoTypeLongBinary
    GetFieldIsBinary = True
 End Select
End Property

Public Property Get FieldsCount() As Long
    FieldsCount = lngFieldsCount
End Property

Public Property Get RecordCount(Optional fIncludeDeleted As Boolean) As Long
'Возвращает количество актуальных записей, или, если установлен
' fIncludeDeleted, общее количество, включая удаленные.
'Текущая запись не смещается.
Dim lngSaveCurRec As Long, lngActualRec As Long
Dim i As Long, lngAddress As Long
 If fIncludeDeleted Or Head.RecordCount = 0 Then
    RecordCount = Head.RecordCount
    Exit Property
 End If
    
    lngSaveCurRec = CurRec
    ReDim CurData(0 To 0)
    lngAddress = Head.Offset + 1
 For i = 0 To Head.RecordCount - 1
    Get hFile, lngAddress, CurData
  If Not RecordIsDeleted Then lngActualRec = lngActualRec + 1
    lngAddress = lngAddress + lngRecordLen
 Next
    ReDim CurData(0 To lngRecordLen - 1)
    GoToRecord lngSaveCurRec
    CurRec = lngSaveCurRec
    
    RecordCount = lngActualRec
End Property

Public Property Get AbsolutePosition() As Long
    AbsolutePosition = CurRec
End Property

Public Property Get RecordIsDeleted() As Boolean
 If NoRecord Then Exit Property
    RecordIsDeleted = (CurData(0) <> 32) 'Не пробел - удалена.
End Property

Private Property Get MaxRecordLength() As Long
  If Head.Type = xDBFType_ImpExpSpec Then
    MaxRecordLength = 2147483647 '2^31-1
  Else
    MaxRecordLength = 65535 '2^16-1
  End If
End Property

Public Function MoveFirst(Optional fIncludeDeleted As Boolean) As Boolean
'Переходит на первую актуальную запись, или, если установлен
' fIncludeDeleted, на первую реальную, включая удаленные.
'При успешном перемещении возвращает True.
    MoveFirst = MoveRecord(0, fIncludeDeleted)
End Function

Public Function MoveNext(Optional fIncludeDeleted As Boolean) As Boolean
'Переходит на следующую актуальную запись, или, если установлен
' fIncludeDeleted, на следующую реальную, включая удаленные.
'При успешном перемещении возвращает True.
    MoveNext = MoveRecord(1, fIncludeDeleted)
End Function

Public Function MovePrev(Optional fIncludeDeleted As Boolean) As Boolean
'Переходит на предыдущую актуальную запись, или, если установлен
' fIncludeDeleted, на предыдущую реальную, включая удаленные.
'При успешном перемещении возвращает True.
    MovePrev = MoveRecord(2, fIncludeDeleted)
End Function

Public Function MoveLast(Optional fIncludeDeleted As Boolean) As Boolean
'Переходит на последнюю актуальную запись, или, если установлен
' fIncludeDeleted, на последнюю реальную, включая удаленные.
'При успешном перемещении возвращает True.
    MoveLast = MoveRecord(3, fIncludeDeleted)
End Function

Private Function MoveRecord(intMode As Integer, _
                Optional fIncludeDeleted As Boolean) As Boolean
'Переходит на другую актуальную запись, или, если установлен
' fIncludeDeleted, на реальную, включая удаленные.
'intMode - режим перемещения.
'Режимы "Edit" или "AddNew" сбрасываются.
'При успешном перемещении возвращает True.
Dim lngAddress As Long, intStep As Integer
 
 If NoRecord Then Exit Function
 Select Case intMode
  Case 0 'На первую
    CurRec = 0
    intStep = 1
  Case 1 'На сдедующую
    CurRec = CurRec + 1
    intStep = 1
  Case 2 'На предыдущую
    CurRec = CurRec - 1
    intStep = -1
  Case 3 'На последнюю
    CurRec = Head.RecordCount - 1
    intStep = -1
 End Select
 If bytRecordMode <> 0 Then
    bytRecordMode = 0
    Erase BuffData
 End If
 
 o Until NoRecord
    lngAddress = Head.Offset + CurRec * lngRecordLen + 1
    Get hFile, lngAddress, CurData
  If Not fIncludeDeleted And RecordIsDeleted Then
  Else
    MoveRecord = True
    Exit Function
  End If
    CurRec = CurRec + intStep
 Loop
End Function

Public Sub GoToRecord(lngIndex As Long)
'Переходит на запись с указанным номером, включая удаленные.
'Режимы "Edit" или "AddNew" сбрасываются.
 Select Case lngIndex
  Case 0 To IIf(Head.RecordCount = 0, 0, Head.RecordCount - 1)
  Case Else
    MsgBox "Номер записи должен быть в интервале от 0 до " _
        & Head.RecordCount - 1 & " !", vbExclamation
    Exit Sub
 End Select
    CurRec = lngIndex
    Seek hFile, (Head.Offset + CurRec * lngRecordLen + 1)
 If Not NoRecord Then
'Чтение данных в буфер
    Get hFile, , CurData
 Else
    Erase CurData
 End If
 If bytRecordMode <> 0 Then
    bytRecordMode = 0
    Erase BuffData
 End If
End Sub

Public Property Get NoRecord() As Boolean
    NoRecord = (CurRec >= Head.RecordCount) Or (CurRec < 0)
End Property

Private Function CheckNumField(vIndex As Variant, _
                    Optional fNoMsgNotFound As Boolean) As Long
Dim i As Long, strMsg As String

    CheckNumField = -1
 If VarType(vIndex) = vbString Then
  If Len(Trim$(vIndex)) = 0 Then Exit Function
  For i = 0 To lngFieldsCount - 1
   If StrComp(DBFFieldsExt(i).FieldName, _
                            CStr(vIndex), vbTextCompare) = 0 Then
        CheckNumField = i
        Exit Function
   End If
  Next i
  If Not fNoMsgNotFound Then
    strMsg = "Поле """ & CStr(vIndex) & """ не найдено!"
    ErrorAppend = strMsg
    MsgBox strMsg, vbExclamation
  End If
    Exit Function
 ElseIf IsNumeric(vIndex) Then
  Select Case CInt(vIndex)
   Case Is < 0
   Case 0 To lngFieldsCount - 1
        CheckNumField = CInt(vIndex)
   Case Else
        strMsg = "Номер поля должен быть в пределах от 0 до " _
            & lngFieldsCount - 1 & "!"
        ErrorAppend = strMsg
        MsgBox strMsg, vbExclamation
  End Select
    Exit Function
 Else
    strMsg = "Ссылка на поле должна иметь числовое или" _
        & " строковое значение!"
    ErrorAppend = strMsg
    MsgBox strMsg, vbCritical
    Exit Function
 End If
End Function

Public Function GetFieldValue(vIndex As Variant, _
                Optional ByVal fBinary As Boolean, _
                Optional lngMemoChunkSize As Long, _
                Optional fNullIfNotFoundField As Boolean) As Variant
'Возвращает значение поля, указанного в vIndex (имя или номер).
'fBinary - возвращает байтовый массив, представляющий содержимое поля
' (полезно при создании другого файла на основе текущего для исключения
' лишних преобразований).
'lngMemoChunkSize - размер фрагмента при чтении данных из МЕМО поля
' порциями.
'fNullIfNotFoundField - разрешает возвращать Null без сообщений об
' ошибке при указании неправильного имени или номера поля (при передаче
' пустой строки или номера < 0 возвращает Null в любом случае).
On Error GoTo GetFieldValue_err
Dim lngFieldNum As Long
Dim bytArr() As Byte, vValue As Variant

    GetFieldValue = Null
 If hFile = 0 And Not fNewFile Then Exit Function
 If bytRecordMode = 0 And NoRecord Then Exit Function
 
    lngFieldNum = CheckNumField(vIndex, fNullIfNotFoundField)
 If lngFieldNum < 0 Then Exit Function
    
 With DBFFieldsExt(lngFieldNum)
    ReDim bytArr(0 To .Size - 1)
  If bytRecordMode = 0 Then
   If .Offset > GetArraySize(CurData) Then Exit Function
    CopyMemory bytArr(0), CurData(.Offset), .Size
  Else
   If .Offset > GetArraySize(BuffData) Then Exit Function
    CopyMemory bytArr(0), BuffData(.Offset), .Size
  End If
  If .TypeDAO = daoTypeLongBinary Then fBinary = True
  If .TypeDAO = daoTypeBinary Then fBinary = True
 End With
 If fBinary Then
  Select Case DBFFieldsExt(lngFieldNum).TypeDBF
   Case conFieldTypeMemo, conFieldTypeGeneral
   Case Else
        GetFieldValue = bytArr()
        Exit Function
  End Select
 End If
 
 Select Case DBFFieldsExt(lngFieldNum).TypeDBF
  Case conFieldTypeString
        GetFieldValue = GetString(bytArr)
  Case conFieldTypeNumeric, conFieldTypeFloat
        GetFieldValue = GetNumeric(bytArr)
  Case conFieldTypeDate
        GetFieldValue = GetDate(bytArr)
  Case conFieldTypeLogical
   Select Case bytArr(0)
    Case 89, 121, 84, 116 'Y,y,T,t.
        GetFieldValue = True
    Case Else
        GetFieldValue = False
   End Select
  Case conFieldTypeMemo
        GetFieldValue = GetMemo(bytArr(), lngMemoChunkSize, fBinary)
  
  Case conFieldTypeDateTime
        GetFieldValue = GetDateTime(bytArr)
  Case conFieldTypeLong
        GetFieldValue = GetLong(bytArr)
  Case conFieldTypeDouble
        GetFieldValue = GetDouble(bytArr)
  Case conFieldTypeCurrency
        GetFieldValue = GetCurrency(bytArr)
  Case conFieldTypeInteger
        GetFieldValue = GetInteger(bytArr)
  Case conFieldTypeSingle
        GetFieldValue = GetSingle(bytArr)
  Case conFieldTypeByte
        GetFieldValue = bytArr(0)
  Case conFieldTypeVariant
        GetFieldValue = GetDecimal(bytArr)
 End Select

GetFieldValue_exit:
    Exit Function
GetFieldValue_err:
    MsgBox Err.Description, vbCritical
    Resume GetFieldValue_exit
End Function

Public Property Let SetFieldValue(vIndex As Variant, _
        Optional fWriteMemoChunkMode As Boolean, vValue As Variant)
On Error GoTo SetFieldValue_err
Dim lngFieldNum As Long, strMsg As String
Dim bytArr() As Byte

 If hFile = 0 And Not fNewFile Then Exit Property
 If bytRecordMode = 0 Then
    strMsg = "Сначала укажите ""Edit"" или ""AddNew""!"
    GoTo ErrorMessage
 End If
    lngFieldNum = CheckNumField(vIndex)
 If lngFieldNum < 0 Then Exit Property
 
If IsArray(vValue) Then
 If VarType(vValue) <> (vbArray Or vbByte) Then
        strMsg = "Переданное значение представляет массив с" _
            & " типом данных, отличным от BYTE!"
        GoTo ErrorMessage
  End If
 End If
 With DBFFieldsExt(lngFieldNum)
  If VarType(vValue) = (vbArray Or vbByte) Then
   Select Case DBFFieldsExt(lngFieldNum).TypeDBF
    Case conFieldTypeMemo, conFieldTypeGeneral
    Case Else
        bytArr() = vValue
     If (UBound(bytArr) - LBound(bytArr) + 1) <> .Size Then
        strMsg = "Размер байтового массива не соответствует" _
            & " размеру поля!" & vbCrLf & vbCrLf _
            & "Требуется " & .Size & " байтов."
        GoTo ErrorMessage
     Else
        CopyMemory BuffData(.Offset), bytArr(LBound(bytArr)), .Size
     End If
        Exit Property
   End Select
  ElseIf DBFFieldsExt(lngFieldNum).TypeDAO = daoTypeBinary Then
    strMsg = "Поле """ & DBFFieldsExt(lngFieldNum).FieldName _
            & """ имеет неопознанный тип!" & vbCrLf _
            & " Ему можно присвоить только байтовый массив" _
            & " с размером " & DBFFieldsExt(lngFieldNum).Size _
            & " байтов."
    GoTo ErrorMessage
  End If
 
    ReDim bytArr(0 To .Size - 1)
    CopyMemory bytArr(0), BuffData(.Offset), .Size
 
  Select Case .TypeDBF
   Case conFieldTypeString
        Call SetString(vValue, bytArr, strMsg)
   Case conFieldTypeNumeric, conFieldTypeFloat
        Call SetNumeric(vValue, bytArr, _
            BFFields(lngFieldNum).DecimalPlaces, _
            .TypeDBF = conFieldTypeFloat, strMsg)
   Case conFieldTypeDate
        Call SetDate(vValue, bytArr, strMsg)
   Case conFieldTypeLogical
    If Head.Type = xDBFType_ImpExpSpec Then
        bytArr(0) = 0
    Else
        bytArr(0) = 70 '"F"
    End If
    If IsNumeric(vValue) Then
     If CBool(vValue) Then
        bytArr(0) = 84 '"T"
     End If
    End If
   Case conFieldTypeMemo, conFieldTypeGeneral
        Call SetMemo(hMemoFile, bytArr, vValue, _
            fWriteMemoChunkMode, .TypeDBF = conFieldTypeGeneral, strMsg)
 
   Case conFieldTypeLong, conFieldTypeDouble, conFieldTypeCurrency, _
            conFieldTypeInteger, conFieldTypeSingle, conFieldTypeByte
    If IsNumeric(vValue) Then
     Select Case .TypeDBF
      Case conFieldTypeLong
        CopyMemory bytArr(0), CLng(vValue), 4
      Case conFieldTypeDouble
        CopyMemory bytArr(0), CDbl(vValue), 8
      Case conFieldTypeCurrency
        CopyMemory bytArr(0), CCur(vValue), 8
      Case conFieldTypeInteger
        CopyMemory bytArr(0), CInt(vValue), 2
      Case conFieldTypeSingle
        CopyMemory bytArr(0), CSng(vValue), 4
      Case conFieldTypeByte
        bytArr(0) = CByte(vValue)
     End Select
    Else
     If IsNull(vValue) Then
        ReDim bytArr(0 To .Size - 1)
     Else
        strMsg = "Значение " & vValue & " не является числом!"
        GoTo ErrorMessage
     End If
    End If
   Case conFieldTypeDateTime
        Call SetDateTime(vValue, bytArr)
   Case conFieldTypeVariant
        Call SetDecimal(vValue, bytArr)
  End Select
 
  If UBound(bytArr) >= .Size Then
        strMsg = "Значение " & vValue & " слишком большое!" & vbCrLf _
            & vbCrLf & "Размер поля - " & .Size & " символов."
        GoTo ErrorMessage
  End If
        CopyMemory BuffData(.Offset), bytArr(0), .Size
 End With
 If Len(strMsg) = 0 Then GoTo SetFieldValue_exit
    
ErrorMessage:
        MsgBox strMsg, vbCritical, DBFFieldsExt(lngFieldNum).FieldName
        ErrorAppend = "Поле """ & DBFFieldsExt(lngFieldNum).FieldName _
            & """: " & strMsg
 
SetFieldValue_exit:
    Exit Property
SetFieldValue_err:
    strMsg = Err.Description
    Resume ErrorMessage
End Property

Private Function GetString(bytArr() As Byte) As Variant
Dim s As String, i As Long
   
 If bytArr(0) = 0 Then
        GetString = Null
        Exit Function
 End If
 Select Case lngCharset
  Case xDBFCharsetANSI
        s = StrConv(bytArr(), vbUnicode)
  Case xDBFCharsetUkrStandard
        s = ConvDOStoANSI(bytArr(), fUkrStandard:=True)
  Case Else
        s = ConvDOStoANSI(bytArr())
 End Select
 If Head.Type = xDBFType_ImpExpSpec Then
        i = InStr(1, s, vbNullChar)
  If i > 0 Then s = Left$(s, i - 1)
        GetString = RTrim$(s)
        Exit Function
 Else
        s = RTrim$(s)
  If Len(s) = 0 Then
        GetString = Null
  Else
        GetString = s
  End If
 End If
End Function

Private Function GetDate(bytArr() As Byte) As Variant
Dim intYear As Integer, intMonth As Integer, intDay As Integer
Dim i As Long, v As Integer
 For i = 0 To 7
    v = bytArr(i) - 48
  Select Case v
   Case 0 To 9
   Case Else
        GetDate = Null
        Exit Function
  End Select
  Select Case i
   Case 0: intYear = v * 1000
   Case 1: intYear = intYear + v * 100
   Case 2: intYear = intYear + v * 10
   Case 3: intYear = intYear + v
   Case 4: intMonth = v * 10
   Case 5: intMonth = intMonth + v
   Case 6: intDay = v * 10
   Case 7: intDay = intDay + v
  End Select
 Next i
    GetDate = DateSerial(intYear, intMonth, intDay)
End Function

Private Function GetNumeric(bytArr() As Byte) As Variant
On Error Resume Next
Dim s As String

        s = Trim$(StrConv(bytArr(), vbUnicode))
 If Len(s) > 0 Then
        GetNumeric = Val(s)
  If Err.Number = 0 Then
        Exit Function
  Else
        Err.Clear
  End If
 End If
        GetNumeric = Null

End Function

Private Function GetLong(bytArr() As Byte) As Long
Dim ret As Long
    CopyMemory ret, bytArr(0), 4
    GetLong = ret
End Function

Private Function GetInteger(bytArr() As Byte) As Integer
Dim ret As Integer
    CopyMemory ret, bytArr(0), 2
    GetInteger = ret
End Function

Private Function GetSingle(bytArr() As Byte) As Single
Dim ret As Single
    CopyMemory ret, bytArr(0), 4
    GetSingle = ret
End Function

Private Function GetSpecialInteger(bytArr() As Byte, _
                Optional fLittleEndianFormat As Boolean, _
                Optional lngStartPos As Long, _
                Optional lngLen As Long = 4) As Long
'Возвращает положительное целое число из байтового массива.
'Размер массива или его части, определенной аргументами lngLen
' (размер) и lngStartPos (начальный адрес) должен не превышать 4 байта.
'Если размер менее 4-х байтов - возвращает абсолютное значение, согласно
' весу байтов. Например макс. значение в 2-х байтах (&HFFFF)=65535,
' а не -1 для типа Integer.
'Если указан fLittleEndianFormat - вес байтов в обратном порядке.
Dim i As Long, j As Long, L As Long, U As Long
Dim bytArrTemp(0 To 3) As Byte, lngRet As Long

    L = LBound(bytArr) + lngStartPos
 If L > UBound(bytArr) Then Exit Function
 Select Case lngLen
  Case 1 To 3
    U = L + lngLen - 1
  Case Else
    U = L + 3
 End Select
 If U > UBound(bytArr) Then U = UBound(bytArr)
 
 For i = L To U
  If fLittleEndianFormat Then
    j = U - i
  Else
    j = i - L
  End If
    bytArrTemp(j) = bytArr(i)
 Next i
    CopyMemory lngRet, bytArrTemp(0), 4&
    GetSpecialInteger = lngRet
End Function

Private Function GetDouble(bytArr() As Byte) As Double
Dim ret As Double
    
    CopyMemory ret, bytArr(0), 8
    GetDouble = ret
End Function

Private Function GetCurrency(bytArr() As Byte) As Double
Dim ret As Currency
    
    CopyMemory ret, bytArr(0), 8
    GetCurrency = ret
End Function

Private Function GetDecimal(bytArr() As Byte) As Variant
Dim ret As Variant
    
    CopyMemory ret, bytArr(0), 16
    GetDecimal = ret
End Function

Private Function GetDateTime(bytArr() As Byte) As Variant
Dim ret As Long, dblDateValue As Double, datDate As Date
    
 If Head.Type = xDBFType_ImpExpSpec Then
    CopyMemory dblDateValue, bytArr(0), 8
 Else
    CopyMemory ret, bytArr(0), 4
    dblDateValue = ret - conDateOffset
    CopyMemory ret, bytArr(4), 4
    dblDateValue = dblDateValue + ret / 86400000
 End If
 If dblDateValue = 0 Then
    GetDateTime = Null
 Else
    GetDateTime = CDate(dblDateValue)
 End If
End Function

Private Function GetMemo(bytAddress() As Byte, _
                    Optional lngMemoChunkSize As Long, _
                    Optional fBinary As Boolean, _
                    Optional fGetSize As Boolean) As Variant
On Error GoTo GetMemo_err
Dim lngPageSize As Long
Dim bytArr() As Byte
Dim lngAddress As Long, lngStart As Long, lngLen As Long
Static lngPrevAddress As Long, lngPrevLen As Long, _
    lngOffsetChunk As Long

    GetMemo = Null
 Select Case Head.Type
  Case xDBFType_FoxPro30, xDBFType_ImpExpSpec
'Для Visual FoxPro адрес хранится в 4-х байтах как Long.
    lngAddress = GetLong(bytAddress)
  Case Else
'В других версиях адрес хранится в 10-и байтах как Numeric.
    lngAddress = CLng(MyNZ(GetNumeric(bytAddress), 0))
 End Select
 If lngAddress < 1 Then
'Если адрес не передан или меньше адреса первого блока - прерывается.
    lngPrevAddress = 0
    lngPrevLen = 0
    lngOffsetChunk = 0
    Exit Function
 ElseIf lngAddress <> lngPrevAddress Then
    lngPrevAddress = 0
    lngPrevLen = 0
    lngOffsetChunk = 0
 ElseIf lngOffsetChunk < 0 Then
  If lngMemoChunkSize > 0 Then
'Ранее был считан последний блок.
    Exit Function
  Else
    lngOffsetChunk = 0
  End If
 End If
 If Len(strMemoFullPath) = 0 Then Exit Function
 If hMemoFile = 0 Then
'MEMO файл открывается при первом обращении.
    hMemoFile = FreeFile
    Open strMemoFullPath For Binary Access Read Write As hMemoFile
 End If
 Select Case Head.Type
  Case xDBFType_dBASE_III 'FoxBASE+/dBASE III PLUS, with memo
        lngPageSize = 512
        lngStart = lngAddress * lngPageSize + 1
   If lngAddress = lngPrevAddress And lngPrevLen > 0 Then
        lngLen = lngPrevLen
   Else
        lngLen = CheckMemoLenDBASEIII(hMemoFile, lngStart)
        lngPrevLen = lngLen
   End If
  
  Case xDBFType_dBASE_IV_V 'dBASE IV with memo
        lngPageSize = 512
        lngStart = lngAddress * lngPageSize + 1
'Считывает первые 8 байтов записи.
        ReDim bytArr(0 To 7)
        Get hMemoFile, lngStart, bytArr
'Проверяет значение 0-3 байтов. Должно быть FF FF 08 00.
   If GetSpecialInteger(bytArr) <> &H8FFFF Then GoTo GetMemo_exit
'Из 3-7 байта считывается длина записи, включающая первые 8 байтов.
        lngLen = GetSpecialInteger(bytArr, , 3)
'Данные начинаются с 8-го байта, поэтому корректируется длина и
'стартовая позиция.
        lngStart = lngStart + 8
        lngLen = lngLen - 8
  
  Case Else 'FoxPro 2.x, FoxPro 3.0, ImpExpSpec
'В массив считываются 4 байта (4-7) заголовка, из которых получаем
'размер страницы (вес байтов - по убыванию).
        ReDim bytArr(0 To 3)
        Get hMemoFile, 5, bytArr
        lngPageSize = GetSpecialInteger(bytArr, True)
        lngStart = lngAddress * lngPageSize + 1
        ReDim bytArr(0 To 7)
        Get hMemoFile, lngStart, bytArr()
        fBinary = (bytArr(3) = 0)
        lngLen = GetSpecialInteger(bytArr, True, 4)
        lngStart = lngStart + 8
 End Select
        
        lngPrevAddress = lngAddress
 
 If fGetSize Then
    GetMemo = lngLen
    GoTo GetMemo_exit
 End If
 
 If lngMemoChunkSize > 0 Then
        lngStart = lngStart + lngOffsetChunk
  If lngOffsetChunk + lngMemoChunkSize >= lngLen Then
        lngLen = lngLen - lngOffsetChunk
        lngOffsetChunk = -1
  Else
        lngLen = lngMemoChunkSize
        lngOffsetChunk = lngOffsetChunk + lngMemoChunkSize
  End If
 End If
 If lngLen <= 0 Then GoTo GetMemo_exit
        
        ReDim bytArr(0 To lngLen - 1)
        Get hMemoFile, lngStart, bytArr()
 
 If fBinary Then
        GetMemo = bytArr()
 Else
        GetMemo = GetString(bytArr)
 End If
 
GetMemo_exit:
    Exit Function
GetMemo_err:
    MsgBox Err.Description, vbCritical
    Resume GetMemo_exit
End Function

Public Function GetMemoDataSize(vIndex As Variant) As Long
'Возвращает размер данных в MEMO поле текущей записи.
Dim lngFieldNum As Long, bytArr() As Byte

 If hFile = 0 And Not fNewFile Then Exit Function
 If bytRecordMode = 0 And NoRecord Then Exit Function

    lngFieldNum = CheckNumField(vIndex)
 If lngFieldNum < 0 Then Exit Function

 With DBFFieldsExt(lngFieldNum)
  Select Case DBFFieldsExt(lngFieldNum).TypeDBF
   Case conFieldTypeMemo, conFieldTypeGeneral
   Case Else: Exit Function
  End Select
  
    ReDim bytArr(0 To .Size - 1)
  If bytRecordMode = 0 Then
   If .Offset > GetArraySize(CurData) Then Exit Function
    CopyMemory bytArr(0), CurData(.Offset), .Size
  Else
   If .Offset > GetArraySize(BuffData) Then Exit Function
    CopyMemory bytArr(0), BuffData(.Offset), .Size
  End If
 End With
    GetMemoDataSize = CLng(MyNZ(GetMemo(bytArr, , , True), 0))
End Function

Private Function CheckMemoLenDBASEIII(hMemoFile As Integer, _
                                        lngStart As Long) As Long
'Выполняет поиск конца записи (&H1А &H1А) в DBT файле DbaseIII.
'hMemoFile - дискриптор открытого файла.
'lngStart - адрес начала записи.
On Error GoTo CheckMemoLenDBASEIII_err
Dim bytArr() As Byte, lngTemp As Long
Dim i As Long, fLastSimbolIsTerminator As Boolean
Const conPageSize = 512

    ReDim bytArr(0 To conPageSize - 1)
    lngTemp = lngStart
'В цикле выполняется постраничное считывание в массив и анализ:
' Если последний символ не 0 и не 1А - следующая страница;
' Если 2 последних символа = &H1А, - нашла;
' Если последний символ = &H1А, читает следующую страницу и
' проверяет 1-й символ. Если = &H1А, - нашла;
' Если последний символ = 0, выполняет цикл побайтового считывания
' в массиве. Если есть &H1А &H1А, - нашла.
'В lngTemp записывается адрес страницы, а когда конец записи найден, -
' адрес последнего символа перед &H1А.
'Цикл продолжается не будет найден конец записи, или достигнут конец
' файла
 o
  If EOF(hMemoFile) Then Exit Function
        
        Get hMemoFile, lngTemp, bytArr()
  
  If fLastSimbolIsTerminator And bytArr(0) = conFileTerminator Then
        lngTemp = lngTemp + 1
        Exit Do
  End If
  Select Case bytArr(conPageSize - 1)
   Case 0, conFileTerminator
   Case Else
        GoTo NextPage
  End Select
  If bytArr(conPageSize - 1) = conFileTerminator Then
   If bytArr(conPageSize - 2) = conFileTerminator Then
        lngTemp = lngTemp + conPageSize
        Exit Do
   Else
        fLastSimbolIsTerminator = True
   End If
  End If
  For i = 0 To conPageSize - 2
   If bytArr(i) = conFileTerminator Then
    If bytArr(i + 1) = conFileTerminator Then
        lngTemp = lngTemp + i + 1
        Exit Do
    End If
   End If
  Next i
NextPage:
    lngTemp = lngTemp + conPageSize
 Loop
'Длина строки - разность между конечным и начальным адресом.
    CheckMemoLenDBASEIII = lngTemp - lngStart - 1

CheckMemoLenDBASEIII_exit:
    Exit Function
CheckMemoLenDBASEIII_err:
    Resume CheckMemoLenDBASEIII_exit
End Function

Private Function SetString(vValue As Variant, bytArr() As Byte, _
            Optional strErrMsg As String) As Boolean
Dim strValue As String
Dim lngLenStr As Long, lngLenArr As Long

    lngLenArr = GetArraySize(bytArr)
 If IsNull(vValue) Then
  If Head.Type = xDBFType_ImpExpSpec Then
'Для формата ImpExpSpec при значении Null во всех байтах - 0.
    ReDim bytArr(0 To lngLenArr - 1)
    GoTo Finish
  End If
    strValue = vbNullString
 Else
    strValue = CStr(vValue)
 End If
    
    lngLenStr = Len(strValue)
 Select Case lngLenStr
  Case Is < lngLenArr
    strValue = strValue & String(lngLenArr - lngLenStr, 32)
  Case Is > lngLenArr
    strErrMsg = "Длина строки (" & lngLenStr & " символов)" _
        & " превышает размер поля! Cохранены" _
        & " первые " & lngLenArr & " символов."
    strValue = Left$(strValue, lngLenArr)
 End Select
 Select Case lngCharset
  Case xDBFCharsetANSI
  Case xDBFCharsetUkrStandard
    strValue = ConvANSItoDOS(strValue, fUkrStandard:=True)
  Case Else
    strValue = ConvANSItoDOS(strValue)
 End Select
    bytArr() = StrConv(strValue, vbFromUnicode)

Finish:
    SetString = True
End Function

Private Function SetNumeric(vValue As Variant, bytArr() As Byte, _
            Optional ByVal lngDecPlaces As Long, _
            Optional fFloat As Boolean, _
            Optional strErrMsg As String) As Boolean
Dim strFormat As String, strValue As String
Dim lngLenStr As Long, lngLenArr As Long
Dim strDecSep As String * 1, lngDecSepPos As Long

    strDecSep = Mid$(CStr(1.1), 2, 1)
 If lngDecPlaces > 0 Then
  If fFloat Then
    strFormat = "0." & String(lngDecPlaces, 35) '35 - "#"
  Else
    strFormat = "0." & String(lngDecPlaces, 48) '48 - "0"
  End If
 Else
    strFormat = "0"
 End If
 If IsNumeric(vValue) Then
        strValue = Format$(vValue, strFormat)
        lngLenStr = Len(strValue)
  If lngDecPlaces > 0 Then
   If Right$(strValue, 1) = strDecSep Then
        lngLenStr = lngLenStr - 1
        strValue = Left(strValue, lngLenStr)
   ElseIf strDecSep <> "." Then
        lngDecSepPos = InStr(1, strValue, strDecSep)
    If lngDecSepPos > 1 Then
        Mid(strValue, lngDecSepPos, 1) = "."
    End If
   End If
  End If
 Else
    strValue = vbNullString
 End If
    lngLenArr = GetArraySize(bytArr)
 Select Case lngLenStr
  Case Is < lngLenArr
    strValue = String(lngLenArr - lngLenStr, 32) & strValue '32 - " "
  Case Is > lngLenArr
    strErrMsg = "Размер поля (" & lngLenArr & " символов)" _
        & " не позволяет сохранить число " & strValue & "!"
    Exit Function
 End Select
    bytArr() = StrConv(strValue, vbFromUnicode)
    SetNumeric = True
End Function

Private Function SetDate(vValue As Variant, bytArr() As Byte, _
            Optional strErrMsg As String) As Boolean
Dim strValue As String
 If IsDate(vValue) Then
    strValue = Format$(vValue, "YYYYMMDD"
 Else
    strValue = String$(8, 32)
  If Not IsNull(vValue) Then
    strErrMsg = "Значение " & vValue & " не является датой!"
  End If
 End If
    bytArr() = StrConv(strValue, vbFromUnicode)
    SetDate = True
End Function

Private Function SetDateTime(vValue As Variant, bytArr() As Byte, _
            Optional strErrMsg As String) As Boolean
Dim dblDateValue As Double, lngDatePart As Long, lngTimePart As Long

 If IsDate(vValue) Then
    dblDateValue = CDbl(CDate(vValue))
 ElseIf IsNull(vValue) Then
    ReDim bytArr(0 To 7)
    SetDateTime = True
    Exit Function
 Else
    strErrMsg = "Значение " & vValue & " не является датой!"
    Exit Function
 End If
 If Head.Type = xDBFType_ImpExpSpec Then
    CopyMemory bytArr(0), dblDateValue, 8
 Else
    lngDatePart = Int(dblDateValue)
    lngTimePart = (dblDateValue - lngDatePart) * 86400000
    lngDatePart = lngDatePart + conDateOffset
    CopyMemory bytArr(0), lngDatePart, 4
    CopyMemory bytArr(4), lngTimePart, 4
 End If
    SetDateTime = True
End Function

Private Function SetMemo(hMemo As Integer, bytAddress() As Byte, _
                    Optional vData As Variant, _
                    Optional fChunkMode As Boolean, _
                    Optional fBinary As Boolean, _
                    Optional strErrMsg As String) As Boolean
'Функция редактирует записи в MEMO файле.
'hMemo - дискриптор файла. Это может быть не только сопровождающий
' файл, но и новый, создаваемый методом Compact.
'bytAddress() - массив, представляющий адрес страницы, с которой
' начинается запись.
'vData - строка или массив, представляющие данные.
'fChunkMode - режим "Добавление частями".
'fBinary - данные хранятся в двоичном виде.
On Error GoTo SetMemo_err
Dim lngNewAddress As Long, lngPageSize As Long
Dim bytArrData() As Byte, lngDataLen As Long, bytArrTemp() As Byte
Dim fNewFormat As Boolean, fFoxProFormat As Boolean
Dim lngAddress As Long, lngStart As Long, lngLen As Long
Static lngPrevAddress As Long, lngPrevLen As Long

 If UBound(bytAddress) = 0 Then
'Специальный режим для вызова из метода "Update".
'Очищает статические переменные после завершения добавления частями.
    lngPrevAddress = 0
    lngPrevLen = 0
    Exit Function
 End If
 
 Select Case VarType(vData)
  Case vbString
        bytArrData() = StrConv(CStr(vData), vbFromUnicode)
  Case (vbArray Or vbByte)
        bytArrData() = vData
 End Select
        lngDataLen = GetArraySize(bytArrData)

 Select Case Head.Type
  Case xDBFType_FoxPro30, xDBFType_ImpExpSpec
'Для FoxPro 3.0 и ImpExpSpec адрес хранится в 4-х байтах как Long.
    lngAddress = GetLong(bytAddress)
    fNewFormat = True
'Значения Long хранятся в обратной последовательности байтов.
    fFoxProFormat = True
  Case Else
'В других версиях адрес хранится в 10-и байтах как Numeric.
    lngAddress = CLng(MyNZ(GetNumeric(bytAddress), 0))
'В FoxPro2x значения Long хранятся в обратной последовательности байтов.
    fFoxProFormat = (Head.Type = xDBFType_FoxPro2x)
 End Select
'Если нет данных - функция прерывается. При этом, если был передан
' адрес (поле заполнялось ранее), и это первое обращение при записи
' по частям - адрес обнуляется (т.е. поле считается пустым).
 If lngDataLen = 0 Then
'Если нет данных...
  If lngAddress > 0 Then
'Если ранее данные вносились...
   If lngAddress <> lngPrevAddress Then
'Если это не завершение добавления частями - возвращается адрес 0,
' т.е. запись зависает.
    If fNewFormat Then
        Call SetSpecialInteger(0, bytAddress)
    Else
        Call SetNumeric(0, bytAddress)
    End If
   Else
'Если это завершение добавления частями (нет данных) - готовит файл
' к добавлению другой записи.
        lngPrevAddress = 0
        lngPrevLen = 0
   End If
  End If
'Завершает процедуру.
        SetMemo = True
        Exit Function
 End If

OpenMemoFile:
 If hMemo = 0 Then
'Если файл не был открыт ранее - открывается указанный в переменной
' заголовка strMemoFullPath.
  If Len(strMemoFullPath) = 0 Then Exit Function
    hMemo = FreeFile
    Open strMemoFullPath For Binary Access Read Write As hMemo
 End If
 
CalculateAdress:
    ReDim bytArrTemp(0 To 7)
    Get hMemo, 1, bytArrTemp
    lngNewAddress = GetSpecialInteger(bytArrTemp, fFoxProFormat)
 
 If fFoxProFormat Then
'Для форматов FoxPro и ImpExp размер страницы хранится в 4-7 байтах
' заголовка (адресация с 0). Если считанный размер = 0, то указывается
' 64 байта.
  If lngNewAddress <> 0 Then
    lngPageSize = GetSpecialInteger(bytArrTemp, True, 4)
  End If
  If lngPageSize = 0 Then lngPageSize = 64
 Else
'Для остальных форматов размер страницы = 512 байтов.
    lngPageSize = 512
 End If
 
 If lngNewAddress = 0 Then
'Новый MEMO файл - создается заголовок.
  If fFoxProFormat Then
   If Head.Type = xDBFType_ImpExpSpec Then
    ReDim bytArrTemp(0 To lngPageSize - 1)
    lngNewAddress = 1
   Else
    ReDim bytArrTemp(0 To 512 - 1)
    lngNewAddress = 8
   End If
    bytArrTemp(3) = lngNewAddress
    bytArrTemp(7) = lngPageSize
  Else
    ReDim bytArrTemp(0 To 512 - 1)
    lngNewAddress = 1
    bytArrTemp(0) = 1
   If Head.Type = xDBFType_dBASE_IV_V Then
'В заголовке для dBaseIV/V в 18-21 байтах - 02 01 00 02.
'Назначение не выяснено!!!?
    bytArrTemp(18) = 2
    bytArrTemp(19) = 1
    bytArrTemp(21) = 2
   End If
  End If
    Put hMemo, 1, bytArrTemp
    Erase bytArrTemp
'Создается первая запись в новом файле.
    lngAddress = lngNewAddress
    GoTo AddNewRecord
 ElseIf lngAddress = 0 Then
'Если адрес страницы не передан - создается новая запись.
    GoTo AddNewRecord
 End If
'Вычисляется адрес первого байта существующей записи.
        lngStart = lngAddress * lngPageSize + 1

 If fChunkMode Then
'Режим добавления по частям.
  If (lngAddress <> lngPrevAddress) Then
'Запись первой части.
        GoTo AddNewRecord
  Else
'Добавление следующей части.
        GoTo SaveData
  End If
 End If

'=== Проверяется возможность замены старых данных новыми ===
'Для всех типов MEMO файлов кроме xDBFType_dBASE_III вычисляется
' кол-во станиц, занятых старыми данными. Если диапазон позволяет, или
' это последняя запись - вносит новые данные поверх старых.
 If Head.Type = xDBFType_dBASE_III Then
'Формат файла - dBaseIII.
'Вычисляется длина записи, сохраненной ранее.
        lngLen = CheckMemoLenDBASEIII(hMemo, lngStart)
        ReDim bytArrTemp(0 To 1)
        bytArrTemp(1) = 2
 Else
'Другие форматы, кроме dBaseIII.
        ReDim bytArrTemp(0 To 3)
        Get hMemo, lngStart + 4, bytArrTemp
  If fFoxProFormat Then
'Для форматов FoxPro и ImpExp длина записи хранится в 4-7 байтах
' (вес байтов - в обратном порядке).
        lngLen = GetSpecialInteger(bytArrTemp, True)
  Else
'Для формата dBaseIV длина записи хранится в 4-7 байтах. В длину
' записи включаются и 1-е 8 служебных байтов.
        lngLen = GetSpecialInteger(bytArrTemp) - 8
  End If
        ReDim bytArrTemp(0 To 1)
        bytArrTemp(0) = 8
 End If
'bytArrTemp(0) - смещение, bytArrTemp(1) - кол-во служебных символов.
 If lngLen <> lngDataLen Then
'Если длина новой и старой записи отличаются - удаляются старые данные.
        ReDim bytArrTemp(0 To (lngLen + bytArrTemp(1) - 1))
        Put hMemo, lngStart + bytArrTemp(0), bytArrTemp
 End If
'Длина использованного пространства вычисляется по формуле:
' Длина старой записи (включающая служебные байты) + число байтов
' до конца последней занятой данными страницы.
        lngLen = lngLen + bytArrTemp(0) + bytArrTemp(1)
 If lngLen Mod lngPageSize > 0 Then
        lngLen = (lngLen \ lngPageSize + 1) * lngPageSize
 End If
'Если новые данные длиннее старых, или это последняя запись -
' пишет поверх. Иначе - создает новую запись.
 If (lngLen < (lngDataLen + bytArrTemp(0) + bytArrTemp(1))) Then
  If (lngAddress + lngLen / lngPageSize) = lngNewAddress Then
        GoTo SaveData
  Else
        GoTo AddNewRecord
  End If
 Else
        GoTo SaveData
 End If

'=================== Новая запись ================================
AddNewRecord:
        lngAddress = lngNewAddress
        lngPrevAddress = 0
'Вычисляется размер открытого файла
        lngPrevLen = LOF(hMemo)
'Вычисляется адрес первого байта новой записи.
        lngStart = lngNewAddress * lngPageSize + 1
'Вычисляется и заполняется 0-ми пространство от последнего символа
' предыдущей записи до начала новой.
 If (lngStart - lngPrevLen) > 1 Then
        ReDim bytArrTemp(0 To (lngStart - lngPrevLen - 2))
        Put hMemo, lngPrevLen + 1, bytArrTemp
 End If
        lngPrevLen = 0
        
'================= Сохранение записи =============================
SaveData:
'В режиме "Добавление частями" данные присоединяются к введенным ранее
' до выполнения метода "Update" или передачи пустого значения, длина
' которых хранится в lngPrevLen и увеличивается после добавления.
 If Head.Type = xDBFType_dBASE_III Then
'Вносит новые данные в формате dBASE_III.
'Запись начинается с 1-й позиции и завершается 2-мя симолами &H1А.
  If fChunkMode Then
        Put hMemo, lngStart + lngPrevLen, bytArrData
        lngPrevAddress = lngAddress
        lngPrevLen = lngPrevLen + lngDataLen
        lngLen = lngPrevLen
  Else
        Put hMemo, lngStart, bytArrData
        lngPrevAddress = 0
        lngPrevLen = 0
        lngLen = lngDataLen
  End If
        ReDim bytArrTemp(0 To 1)
        bytArrTemp(0) = conFileTerminator
        bytArrTemp(1) = conFileTerminator
        Put hMemo, , bytArrTemp
        lngLen = lngLen + 2
        GoTo CalculateNewAddress
 End If

'Вносит новые данные в других форматах.
'Запись начинается с 9-й позиции.
 If fChunkMode Then
  If lngPrevLen = 0 Then
        Put hMemo, lngStart + 8, bytArrData
        lngLen = lngDataLen + 8
  Else
        Put hMemo, lngStart + lngPrevLen, bytArrData
        lngLen = lngDataLen + lngPrevLen
  End If
        lngPrevLen = lngLen
        lngPrevAddress = lngAddress
 Else
        Put hMemo, lngStart + 8, bytArrData
        lngLen = lngDataLen + 8
        lngPrevLen = 0
        lngPrevAddress = 0
 End If

SaveDataLen:
'Заголовок записи сохраняется в 0-3, а длина записи в 4-7 байтах.
        ReDim bytArrTemp(0 To 7)
 If fFoxProFormat Then
'Для форматов FoxPro и ImpExp вес байтов - в обратном порядке.
        Call SetSpecialInteger(lngLen - 8, bytArrTemp, True, 4)
  If Not fBinary Then
'В FoxPro 3-й байт = 1, если текстовые данные, или 0, если двоичные.
        bytArrTemp(3) = 1
  End If
 Else
'Для формата dBaseIV/V длина записи включает 8 служебных байтов.
        Call SetSpecialInteger(lngLen, bytArrTemp, , 4)
'В 0-3 байтах обычно FF FF 08 00.
'Назначение не выяснено!!!?
        bytArrTemp(0) = &HFF
        bytArrTemp(1) = &HFF
        bytArrTemp(2) = 8
 End If
        Put hMemo, lngStart, bytArrTemp

CalculateNewAddress:
'Вычисляется и сохраняется в заголовке файла (0-3 байт) адрес новой
' (будущей) записи.
'К моменту вычисления переменные lngStart и lngLen установлены.
 If lngLen Mod lngPageSize > 0 Then
        lngLen = (lngLen \ lngPageSize + 1) * lngPageSize
 End If
        lngNewAddress = (lngStart - 1 + lngLen) \ lngPageSize
 If fFoxProFormat Then
        ReDim bytArrTemp(0 To 3)
        Call SetSpecialInteger(lngNewAddress, bytArrTemp, True)
        Put hMemo, 1, bytArrTemp
 Else
        Put hMemo, 1, lngNewAddress
 End If

ReturnAddress:
 If fNewFormat Then
    Call SetSpecialInteger(lngAddress, bytAddress)
 Else
    Call SetNumeric(lngAddress, bytAddress)
 End If
    SetMemo = True
    
SetMemo_exit:
    Exit Function
SetMemo_err:
    strErrMsg = Err.Description
    Resume SetMemo_exit
End Function

Private Sub SetSpecialInteger(lngValue As Long, bytArr() As Byte, _
                Optional fLittleEndianFormat As Boolean, _
                Optional lngStartPos As Long, _
                Optional ByVal bytLen As Byte)
'Вносит целое число в байтовый массив.
'Размер массива или его части, определенной аргументами bytLen
' (размер) и lngStartPos (начальный адрес) должен не превышать 4 байта.
'Если размер менее 4-х байтов - вносит абсолютное значение, согласно
' весу байтов. Например макс. значение в 2-х байтах (&HFFFF)=65535,
' а не -1 для типа Integer.
'Если указан fLittleEndianFormat - вес байтов в обратном порядке.
Dim i As Long, j As Long, L As Long, U As Long
Dim bytArrTemp(0 To 3) As Byte, lngRet As Long

    L = LBound(bytArr) + lngStartPos
 If L > UBound(bytArr) Then Exit Sub
    CopyMemory bytArrTemp(0), lngValue, 4&
 Select Case bytLen
  Case 1 To 3
    U = L + bytLen - 1
  Case Else
    U = L + 3
 End Select
 If U > UBound(bytArr) Then
    U = UBound(bytArr)
 End If
 For i = L To U
  If fLittleEndianFormat Then
    j = U - i
  Else
    j = i - L
  End If
    bytArr(i) = bytArrTemp(j)
 Next i
End Sub

Private Function SetDecimal(vValue As Variant, bytArr) As Boolean
On Error Resume Next
    CopyMemory bytArr(0), vValue, 16&
    SetDecimal = (Err.Number = 0)
End Function

Public Sub Edit()
 If fNewFile Or NoRecord Then
    MsgBox "Нет записи!", vbExclamation
    Exit Sub
 End If
 If Not AllowModify Then Exit Sub
 If RecordIsDeleted Then
    MsgBox "Запись удалена!", vbExclamation
    Exit Sub
 End If
    BuffData = CurData
    bytRecordMode = 1
End Sub

Public Sub AddNew()
Dim i As Long, bytArr() As Byte
 If fNewFile Then
  If lngFieldsCount = 0 Then
    MsgBox "Поля еще не созданы!", vbExclamation
    Exit Sub
  End If
 End If
 If Not AllowModify Then Exit Sub
 
 If Head.Type = xDBFType_ImpExpSpec Then
'Для формата ImpExpSpec создается пустой буфер требуемой длины.
    ReDim BuffData(0 To lngRecordLen - 1)
    BuffData(0) = 32 'Пробел - в признак удаления.
    GoTo Finish
 End If
'Создается буфер записи требуемой длины, заполненный пробелами.
    BuffData = StrConv(Space(lngRecordLen), vbFromUnicode)
'Для некоторых полей вместо пробелов вносятся 0 или код "F" для
' логических полей.
 For i = 0 To lngFieldsCount - 1
  With DBFFieldsExt(i)
   Select Case .TypeDBF
    Case conFieldTypeMemo, conFieldTypeGeneral
     If .Size = 10 Then GoTo NextField
    Case conFieldTypeLogical
        BuffData(.Offset) = 70 '"F"
        GoTo NextField
    Case conFieldTypeString, conFieldTypeNumeric, conFieldTypeDate
        GoTo NextField
   End Select
        ReDim bytArr(0 To .Size - 1)
        CopyMemory BuffData(.Offset), bytArr(0), .Size
  End With
NextField:
 Next i
 
Finish:
    bytRecordMode = 2
End Sub

Public Sub Update()
Dim i As Integer
    
 Select Case bytRecordMode
  Case 1 'Редактируется существующая запись
    Seek hFile, (Head.Offset + CurRec * lngRecordLen + 1)
    Put hFile, , BuffData
    CurData = BuffData
  Case 2 'Новая запись
   If fNewFile Then
    If Not SaveNewFile Then Exit Sub
   End If
    Seek hFile, (Head.Offset + Head.RecordCount * lngRecordLen + 1)
    Put hFile, , BuffData 'Добавляем новую запись
    CurData = BuffData
    
    Put hFile, , conFileTerminator 'Добавляем конец файла
    
    LastDateUpdate = Date
    Head.RecordCount = Head.RecordCount + 1
    Put hFile, 5, Head.RecordCount 'Меняем кол-во записей в заголовке
    CurRec = Head.RecordCount - 1
 End Select
    
    bytRecordMode = 0

'Завершает процесс добавления в MEMO поле по частям.
    ReDim BuffData(0)
    Call SetMemo(0, BuffData)
    
    Erase BuffData
End Sub

Public Sub Delete()
 If NoRecord Then Exit Sub
 If RecordIsDeleted Then Exit Sub
 If Not AllowModify Then Exit Sub
 
    Seek hFile, (Head.Offset + CurRec * lngRecordLen + 1)
    Put hFile, , conDeleteMark
    CurData(0) = conDeleteMark
End Sub

Public Sub UnDelete()
 If NoRecord Then Exit Sub
 If Not RecordIsDeleted Then Exit Sub
 If Not AllowModify Then Exit Sub
 
    Seek hFile, (Head.Offset + CurRec * lngRecordLen + 1)
    Put hFile, , CByte(32) 'записывается пробел
    CurData(0) = 32
End Sub

Public Function FindFirst(vField As Variant, _
    vFindValue As Variant, Optional fNotEqv As Boolean, _
    Optional fIncludeDeleted As Boolean) As Boolean
        FindFirst = FindRecord(vField, vFindValue, fNotEqv, True, _
                                                    fIncludeDeleted)
End Function
        
Public Function FindNext(vField As Variant, _
    vFindValue As Variant, Optional fNotEqv As Boolean, _
    Optional fIncludeDeleted As Boolean) As Boolean
        FindNext = FindRecord(vField, vFindValue, fNotEqv, , _
                                                    fIncludeDeleted)
End Function

Private Function FindRecord(vField As Variant, _
    vFindValue As Variant, Optional fNotEqv As Boolean, _
    Optional fFindFirst As Boolean, _
    Optional fIncludeDeleted As Boolean) As Boolean
'Ищет запись, в которой значение поля vField соответствует значению
' vFindValue (или не соответствует, если указан fNotEqv).
'Поиск выполняется с первой записи, если указан fFindFirst), или
' со следующей. Если совпадение найдено - возвращает True, иначе
' текущей остается запись, на которой был указатель перед поиском.
'Если указан fIncludeDeleted, то ищет во всех записях, включая
' удаленные.
Dim lngFieldNum As Long, vValue As Variant
Dim lngCurRecord As Long, fFound As Boolean

 If hFile = 0 Or fNewFile Then Exit Function
    lngFieldNum = CheckNumField(vField)
 If lngFieldNum < 0 Then Exit Function

    lngCurRecord = CurRec
    bytRecordMode = 0
 If fFindFirst Then
    Call MoveFirst(fIncludeDeleted)
 Else
    Call MoveNext(fIncludeDeleted)
 End If
 o Until NoRecord
        vValue = GetFieldValue(lngFieldNum)
  If IsNull(vFindValue) Then
        fFound = IsNull(vValue)
        GoTo NextRecord
  End If
  Select Case GetFieldTypeForDAO(lngFieldNum)
   Case daoTypeBinary, daoTypeLongBinary
        Exit Function
   Case daoTypeText, daoTypeMemo
    If vValue Like vFindValue Then fFound = True
   Case daoTypeBoolean
    If IsNumeric(vFindValue) Then
     If vValue Eqv CBool(vFindValue) Then fFound = True
    End If
   Case daoTypeDate
    If IsDate(vFindValue) Then
     If vValue = vFindValue Then fFound = True
    End If
   Case Else
    If IsNumeric(vFindValue) Then
     If vValue = vFindValue Then fFound = True
    End If
  End Select
  
NextRecord:
  If fNotEqv Then fFound = Not fFound
  If fFound Then
    FindRecord = True
    Exit Function
  End If
    Call MoveNext(fIncludeDeleted)
 Loop
    GoToRecord lngCurRecord
End Function

Public Function CompactDBF(Optional strFilePath As String, _
                    Optional strNewFilePath As String) As Long
On Error GoTo CompactDBF_err
Dim hNewFile As Integer, lngDelRecCount As Long
Dim fTempFile As Boolean, fSomeFile As Boolean
Dim bytArr() As Byte
Dim NewHead As DBFHeader
Dim strNewMemoPath As String, hNewMemoFile As Integer, fIsMemo As Boolean
Const conTempFileName = "Temp.dbf"

 If Len(strFilePath) = 0 Then
  If hFile = 0 Then Exit Function
    strFilePath = strDBFFullPath
    fSomeFile = True
 ElseIf StrComp(strFilePath, strDBFFullPath, vbTextCompare) = 0 Then
  If hFile = 0 Then
   If Not OpenFile(strFilePath) Then Exit Function
  End If
    fSomeFile = True
 Else
  If hFile <> 0 Then
   If MsgBox("Ранее был открыт файл " & vbCrLf _
        & strDBFFullPath & "." & vbCrLf & vbCrLf _
        & "Закрыть его и продололжать?", vbQuestion + vbOKCancel + _
        vbDefaultButton2, "Сжатие " & strFilePath) = vbCancel Then
    Exit Function
   End If
  End If
  If Not OpenFile(strFilePath) Then Exit Function
 End If
 If Len(strNewFilePath) = 0 Then
    strNewFilePath = strFolder & conTempFileName
    fTempFile = True
 ElseIf StrComp(strFilePath, strNewFilePath, vbTextCompare) = 0 Then
    strNewFilePath = strFolder & conTempFileName
    fTempFile = True
 End If
 If CheckFileExists(strNewFilePath) Then
  If Not fTempFile Then
   If MsgBox("Файл " & strNewFilePath & ", в котором должна быть" _
    & " сохранена сжатая копия, существует!" & vbCrLf & vbCrLf _
    & "Удалить?", vbQuestion + vbOKCancel + _
    vbDefaultButton2) = vbCancel Then
        Exit Function
   End If
  End If
    Kill strNewFilePath
 End If
    hNewFile = FreeFile
    Open strNewFilePath For Binary Access Write As hNewFile
 If Len(strMemoFullPath) > 0 Then
  Select Case Head.Type
   Case xDBFType_FoxPro2x, xDBFType_FoxPro30
        strNewMemoPath = ChangeFileExtention(strNewFilePath, "fpt"
   Case Else
        strNewMemoPath = ChangeFileExtention(strNewFilePath, "dbt"
  End Select
  If CheckFileExists(strNewMemoPath) Then
    Kill strNewMemoPath
  End If
    hNewMemoFile = FreeFile
    Open strNewMemoPath For Binary Access Read Write As hNewMemoFile
    fIsMemo = (hNewMemoFile <> 0)
 End If
    
    ReDim bytArr(0 To Head.Offset - 1)
    Get hFile, 1, bytArr()
    Put hNewFile, , bytArr()
    ReDim bytArr(0)
    
    Call MoveFirst(True)
 o Until NoRecord
  If RecordIsDeleted Then
    lngDelRecCount = lngDelRecCount + 1
  Else
   If fIsMemo Then
'Если есть MEMO файл и не было ошибок при формировании копии, -
' выполняет копирование MEMO полей и модификацию адресов.
    fIsMemo = CompactMemo(hNewMemoFile)
   End If
    Put hNewFile, , CurData
  End If
    Call MoveNext(True)
 Loop
    Put hNewFile, , conFileTerminator 'Добавляем конец файла
    
 With NewHead
    .Dat(0) = Year(Date) - 1900
    .Dat(1) = Month(Date)
    .Dat(2) = Day(Date)
    .RecordCount = Head.RecordCount - lngDelRecCount
 End With
    Put hNewFile, 2, NewHead.Dat
 If lngDelRecCount > 0 Then
    Put hNewFile, 5, NewHead.RecordCount
 End If
    Close #hNewFile
    hNewFile = 0
'--------------------------------------------------------
 If fTempFile Then
'Если предполагается замена исходных файлов сжатыми копиями.
  If hNewMemoFile <> 0 Then
'Если MEMO файл существует, и он благополучно ужат до меньшего размера,
' то исходный MEMO файл заменяется новым, предварительно сохранив
' страховую копию с расширением BAK.
   If hMemoFile <> 0 Then Close #hMemoFile
        Close #hNewMemoFile
        hNewMemoFile = 0
   If fIsMemo And CheckFileExists(strNewMemoPath) Then
    If FileLen(strNewMemoPath) < FileLen(strMemoFullPath) Then
        FileCopy strMemoFullPath, strMemoFullPath & ".bak"
        FileCopy strNewMemoPath, strMemoFullPath
    End If
        Kill strNewMemoPath
   End If
  End If
  If lngDelRecCount = 0 Then
'Если в исходном файле не было удаленных записей - новая копия
' удаляется.
        Kill strNewFilePath
        Exit Function
  Else
    Close #hFile
    hFile = 0
'Если исходный файл ужат, то он заменяется новым, предварительно
' сохранив страховую копию с расширением BAK.
    FileCopy strDBFFullPath, strDBFFullPath & ".bak"
    FileCopy strNewFilePath, strDBFFullPath
    Kill strNewFilePath
  End If
  If fSomeFile Then
'Открывается обновленный файл.
    Call OpenFile(strFilePath)
  End If
 End If
    CompactDBF = lngDelRecCount

CompactDBF_exit:
On Error Resume Next
 If hNewFile <> 0 Then Close #hNewFile
 If hNewMemoFile <> 0 Then Close #hNewMemoFile
    Exit Function
CompactDBF_err:
    MsgBox Err.Description, vbCritical
    Resume CompactDBF_exit
End Function

Private Function CompactMemo(hNewMemoFile As Integer) As Boolean
'Вспомогательная функция для CompactDBF. Переписывает данные в новый
' MEMO файл, отбрасывая потерянные записи и модифицирует адреса в
' полях.
Dim bytAddr() As Byte, vData As Variant, i As Long
Const conChunkSize As Long = 8192

 For i = 0 To FieldsCount - 1
  With DBFFieldsExt(i)
   Select Case .TypeDAO
    Case daoTypeMemo, daoTypeLongBinary
'Считывается адрес из MEMO поля.
        ReDim bytAddr(0 To .Size - 1)
        CopyMemory bytAddr(0), CurData(.Offset), .Size
     o
'Чтение и запись данных выполняется порциями, если их размер превышает
' значение в conChunkSize.
        vData = GetMemo(bytAddr, conChunkSize, True)
      If Not SetMemo(hNewMemoFile, bytAddr, vData, True, _
                                .TypeDAO = daoTypeLongBinary) Then
'Если при записи возникает ошибка, то функция больше не вызывается.
            CompactMemo = False
            Exit Function
      End If
     Loop Until IsNull(vData)
'Модифицируется адрес в MEMO поле.
        CopyMemory CurData(.Offset), bytAddr(0), .Size
   End Select
  End With
 Next i
        CompactMemo = True
End Function

Public Sub CloseFile()
On Error Resume Next
 If hFile <> 0 Then Close hFile
 If hMemoFile <> 0 Then Close hMemoFile
 
    hFile = 0
    hMemoFile = 0
    
    strDBFFullPath = vbNullString
    strFolder = vbNullString
    Erase CurData
    Erase BuffData
    Erase DBFFields
    Erase DBFFieldsExt
    lngFieldsCount = 0
    CurRec = 0
    Head.Type = 0
    Head.RecordCount = 0
End Sub

Public Property Get LastDateUpdate() As Date
    LastDateUpdate = DateSerial(Head.Dat(0) + 1900, _
                                            Head.Dat(1), Head.Dat(2))
End Property

Public Property Let LastDateUpdate(NewDate As Date)
 If hFile = 0 Then Exit Property
 If Not AllowModify Then Exit Property
 With Head
    .Dat(0) = Year(NewDate) - 1900
    .Dat(1) = Month(NewDate)
    .Dat(2) = Day(NewDate)
 End With
    Put hFile, 2, Head.Dat
End Property

Private Function ChangeFileExtention(strFilePath As String, _
                Optional ByVal strNewExt As String) As String
Dim bytArr() As Byte, i As Long
    
 If Len(strFilePath) = 0 Then Exit Function
 If Len(strNewExt) > 0 Then
  If Asc(strNewExt) <> 46 Then '"."
    strNewExt = "." & strNewExt
  End If
 End If
 
    bytArr = StrConv(strFilePath, vbFromUnicode)
 For i = UBound(bytArr) To LBound(bytArr) Step -1
  If bytArr(i) = 46 Then '"."
    Exit For
  End If
  If bytArr(i) = 92 Then '"\"
    i = 0
    Exit For
  End If
 Next i
 If i = 0 Then
    ChangeFileExtention = strFilePath & strNewExt
 Else
    ChangeFileExtention = Left$(strFilePath, i) & strNewExt
 End If
End Function

Private Function CheckFileExists(strFilePath As String, _
            Optional strRetFolder As String) As Boolean
On Error Resume Next
Dim i As Long
    i = Len(Dir$(strFilePath))
 If Err <> 0 Then Err.Clear: Exit Function
 If i = 0 Then Exit Function
    strRetFolder = Left$(strFilePath, Len(strFilePath) - i)
    CheckFileExists = True
End Function

Private Function GetArraySize(bytAtt() As Byte) As Long
On Error Resume Next

    GetArraySize = UBound(bytAtt) - LBound(bytAtt) + 1
 If Err <> 0 Then
    Err.Clear
    GetArraySize = 0
 End If
End Function

Private Function AllowModify() As Boolean
 If fRO Then
    MsgBox "Файл доступен только на чтение!", vbExclamation
    Exit Function
 End If
    AllowModify = True
End Function

Public Property Get xDBFType_dBASE_III() As Long
    xDBFType_dBASE_III = &H83 'dBASE III+ with memo
End Property

Public Property Get xDBFType_dBASE_IV_V() As Long
    xDBFType_dBASE_IV_V = &H8B 'dBASE IV/V with memo
End Property

Public Property Get xDBFType_FoxPro2x() As Long
    xDBFType_FoxPro2x = &HF5 'FoxPro 2.x (or earlier) with memo
End Property

Public Property Get xDBFType_FoxPro30() As Long
    xDBFType_FoxPro30 = &H30 'FoxPro 3.x (Visual FoxPro)
End Property

Public Property Get xDBFType_ImpExpSpec() As Long
    xDBFType_ImpExpSpec = &H77 'Специальный файл для обмена данными
End Property

Public Property Get xDBFCharsetDOS866() As Long
    xDBFCharsetDOS866 = 1 'DOS 866-я кодовая страница
End Property

Public Property Get xDBFCharsetANSI() As Long
    xDBFCharsetANSI = 3 'Кодировка Windows
End Property

Public Property Get xDBFCharsetUkrStandard() As Long
    xDBFCharsetUkrStandard = 2 'DOS Украинский стандарт
End Property

Function MyNZ(vValue As Variant, Optional vDefValue As Variant) As Variant
'Аналог функции Access NZ()
 If IsNull(vValue) Then
  If Not IsMissing(vDefValue) Then
    MyNZ = vDefValue
  End If
 Else
    MyNZ = vValue
 End If
End Function

Private Property Let ErrorAppend(strText As String)
 If Len(strError) = 0 Then
    strError = strText
 Else
    strError = strError & vbCrLf & strText
 End If
End Property

Public Property Get ErrorDescription() As String
    ErrorDescription = strError
End Property

Public Sub ErrorClear()
    strError = vbNullString
End Sub

Private Sub Class_Terminate()
 If hFile <> 0 Then Close hFile
 If hMemoFile <> 0 Then Close hMemoFile
End Sub

'======= Функции преобразования кодировок ========================
Function SpellIiCcLangInString(strText As String, _
                        Optional fCheckIi As Boolean, _
                        Optional fCheckCc As Boolean) As Long
'Ищет в строке и исправляет кодировку (Eng - Cyr или наоборот)
' символов "І", "і" (если указан fCheckIi), и/или "С", "с"
' (если указан fCheckСс).
'Например английская "с" в русском слове, или наоборот.
'Подробнее см. функцию ChangeIiCcLangInArray.
Dim bArr() As Byte, i As Long, j As Long
  
 If Not fCheckIi Or Not fCheckCc Then Exit Function
 If Len(strText) = 0 Then Exit Function
 
    bArr = StrConv(strText, vbFromUnicode)
 For i = LBound(bArr) To UBound(bArr)
  If ChangeIiCcLangInArray(bArr, i, fCheckIi, fCheckCc) Then
        j = j + 1
  End If
 Next i
 If j > 0 Then
        strText = StrConv(bArr, vbUnicode)
 End If
        SpellIiCcLangInString = j
End Function

Private Function ConvANSItoDOS(strText, _
            Optional fUkrStandard As Boolean) As String
'Перекодировка строки из Windows в Dos.
'По умолчанию перекодировка в 866 таблицу. Если установлен
' флажок fUkrStandard - украинские символы по стандарту.
'Используется преобразование строки в байтовый массив и обратно.
Dim bArr() As Byte, i As Long, fIsChange As Boolean

 If Len(strText) = 0 Then Exit Function
    
'Преобразование строки из UniCode в ANSI и заполнение массива.
    bArr() = StrConv(strText, vbFromUnicode)
 
 For i = LBound(bArr) To UBound(bArr)
   Select Case bArr(i)
    Case Is < 161
    Case 192 To 239 ' от "А" до "п"
        bArr(i) = bArr(i) - 64
        fIsChange = True
    Case 240 To 255 ' от "р" до "я"
        bArr(i) = bArr(i) - 16
        fIsChange = True
    Case 168 ' Ё
        bArr(i) = 240
        fIsChange = True
    Case 184 ' ё
        bArr(i) = 241
        fIsChange = True
    Case 178 ' І
        bArr(i) = IIf(fUkrStandard, 246, 73)
        fIsChange = True
    Case 179 ' і
        bArr(i) = IIf(fUkrStandard, 247, 105)
        fIsChange = True
    Case 170 ' Є
        bArr(i) = IIf(fUkrStandard, 244, 242)
        fIsChange = True
    Case 186 ' є
        bArr(i) = IIf(fUkrStandard, 245, 243)
        fIsChange = True
    Case 175 ' Ї
        bArr(i) = IIf(fUkrStandard, 248, 244)
        fIsChange = True
    Case 191 ' ї
        bArr(i) = IIf(fUkrStandard, 249, 245)
        fIsChange = True
    Case 161 ' Ў
        bArr(i) = 246
        fIsChange = True
    Case 162 ' ў
        bArr(i) = 247
        fIsChange = True
    Case 165 ' Ґ
        bArr(i) = 242
        fIsChange = True
    Case 180 ' ґ
        bArr(i) = 243
        fIsChange = True
    Case 185 '№
        bArr(i) = 252
        fIsChange = True
    Case 167 '§
        bArr(i) = 21
        fIsChange = True
    Case 171 '«
        bArr(i) = 60 'Преобразование в "<"
        fIsChange = True
    Case 187 '»
        bArr(i) = 62 'Преобразование в ">"
        fIsChange = True
   End Select
 Next i
'Преобразование массива в строку(UniCode).
 If fIsChange Then
    ConvANSItoDOS = StrConv(bArr(), vbUnicode)
 Else
    ConvANSItoDOS = strText
 End If
End Function

Private Function ConvDOStoANSI(strText As Variant, _
            Optional fUkrStandard As Boolean) As String
'Перекодировка строки из Dos в Windows.
'По умолчанию перекодировка из 866 таблицы.
'Если установлен флажок fUkrStandard - укр. символы по стандарту.
'Символы "І" и "і" в 866 таблице равноценны для английского и
' украинского языков. При перекодировке проверяется принадлеж-
' ность предыдущего и/или следующего символа к кирилице. Если ДА -
' перекодируется, иначе - не меняется.
'Используется преобразование строки в байтовый массив и обратно.
Dim bArr() As Byte, i As Long
Dim fIsChange As Boolean, fIsIi As Boolean

'Аргумент strText может быть только строкой или байтовым массивом.
 Select Case VarType(strText)
  Case vbString
   If Len(strText) = 0 Then Exit Function
'Преобразование строки из UniCode в OEM и заполнение массива.
    bArr() = StrConv(strText, vbFromUnicode)
  Case (vbArray Or vbByte)
    bArr() = strText
  Case Else
    Exit Function
 End Select
 For i = LBound(bArr) To UBound(bArr)
   Select Case bArr(i)
    Case 21 '§
        bArr(i) = 167
        fIsChange = True
    Case 73, 105 ' І,i (лат. или укр.)
     If Not fUkrStandard Then fIsIi = True
    Case Is < 128
    Case 128 To 175 ' от "А" до "п"
        bArr(i) = bArr(i) + 64
        fIsChange = True
    Case 224 To 239 ' от "р" до "я"
        bArr(i) = bArr(i) + 16
        fIsChange = True
    Case 240 ' Ё
        bArr(i) = 168
        fIsChange = True
    Case 241 ' ё
        bArr(i) = 184
        fIsChange = True
    Case 242 ' Ґ (укр. стандарт) или Є (866)
        bArr(i) = IIf(fUkrStandard, 165, 170)
        fIsChange = True
    Case 243 ' ґ (укр. стандарт) или є (866)
        bArr(i) = IIf(fUkrStandard, 180, 186)
        fIsChange = True
    Case 244 ' Є (укр. стандарт) или Ї (866)
        bArr(i) = IIf(fUkrStandard, 170, 175)
        fIsChange = True
    Case 245 ' є (укр. стандарт) или ї (866)
        bArr(i) = IIf(fUkrStandard, 186, 191)
        fIsChange = True
    Case 246 ' І (укр. стандарт) или Ў (866)
        bArr(i) = IIf(fUkrStandard, 178, 161)
        fIsChange = True
    Case 247 ' і (укр. стандарт) или ў (866)
        bArr(i) = IIf(fUkrStandard, 179, 162)
        fIsChange = True
    Case 248 ' Ї (укр. стандарт)
        bArr(i) = 175
        fIsChange = True
    Case 249 ' ї (укр. стандарт)
        bArr(i) = 191
        fIsChange = True
    Case 252 '№
        bArr(i) = 185
        fIsChange = True
   End Select
 Next i
 If fIsChange And fIsIi Then
  For i = LBound(bArr) To UBound(bArr)
   Select Case bArr(i)
    Case 73, 105
        Call ChangeIiCcLangInArray(bArr, i, True)
   End Select
  Next i
 End If
'Преобразование массива в строку(UniCode).
 If fIsChange Or VarType(strText) <> vbString Then
    ConvDOStoANSI = StrConv(bArr(), vbUnicode)
 Else
    ConvDOStoANSI = strText
 End If
End Function

Private Function ChangeIiCcLangInArray(bArr() As Byte, _
                        lngSimbolPos As Long, _
                        Optional fCheckIi As Boolean, _
                        Optional fCheckCc As Boolean) As Boolean
'Проверяет принадлежность символов "I","i" (если указан fCheckIi),
' и/или "C", "c" (если указан fCheckCc) к языку других символов.
'Меняет код Eng на Cyr (или наоборот), если:
' Следующая буква в другой кодировке;
' Следующий символ - не буква и не цифра, а предыдущая буква
' в другой кодировке;
' Символ - первая буква в строке, а ближайшая следующая буква
' в другой кодировке, и между ними нет цифр;
' Символ - первая буква в строке, а ближайшая предыдущая буква
' в другой кодировке, и между ними нет цифр;
' Ближайшие предыдущая и следующая буквы в другой кодировке;
'Если выполнена коррекция - функция возвращает True
'Контроль символов "I","i" полезен после преобразования строки на
' украинском языке из DOS(866) кодировки, а контроль "C", "c" -
' для коррекции ошибок оператора из-за несвоевременного переключения
' раскладки клавиатуры, что может привести к неправильной сортировке,
' поиску или фильтрации.
On Error GoTo ChangeIiCcLangInArray_err
Dim i As Long, bNewCode As Byte
Dim fNextCyr As Boolean, fNextEng As Boolean
Dim fPrevCyr As Boolean, fPrevEng As Boolean
Dim fNextIsNumber As Boolean, fPrevIsNumber As Boolean

 Select Case bArr(lngSimbolPos)
  Case 73, 105, 178, 179 '"I","i" (eng, cyr)
   If Not fCheckIi Then Exit Function
  Case 67, 99, 209, 241 '"C","c" (eng, cyr)
   If Not fCheckCc Then Exit Function
  Case Else
        Exit Function
 End Select

 For i = lngSimbolPos + 1 To UBound(bArr)
  Select Case bArr(i)
   Case 48 To 57 '0-9
        fNextIsNumber = True
        Exit For
   Case 165, 168, 170, 175, 178 To 180, 184, 186, Is >= 191 'Cyr
        fNextCyr = True
   Case 65 To 90, 97 To 122 'Eng
        fNextEng = True
        Exit For
  End Select
 Next i
  
 If fNextCyr Or fNextEng Then
  If (i - lngSimbolPos) = 1 Then
        fPrevCyr = fNextCyr
        fPrevEng = fNextEng
        GoTo ChangeKode
  End If
 End If
 
 For i = lngSimbolPos - 1 To LBound(bArr) Step -1
  Select Case bArr(i)
   Case 48 To 57 '0-9
    If fNextIsNumber Then Exit Function
        fPrevIsNumber = True
        Exit For
   Case 165, 168, 170, 175, 178 To 180, 184, 186, Is >= 191 'Cyr
        fPrevCyr = True
        Exit For
   Case 65 To 90, 97 To 122 'Eng
        fPrevEng = True
        Exit For
  End Select
 Next i

 If fPrevCyr Or fPrevEng Then
  If ((lngSimbolPos - i) = 1) Then
        fNextCyr = fPrevCyr
        fNextEng = fPrevEng
  ElseIf Not fNextCyr And Not fNextEng And Not fNextIsNumber _
                                        And Not fPrevIsNumber Then
        fNextCyr = fPrevCyr
        fNextEng = fPrevEng
  End If
 End If

ChangeKode:
 Select Case bArr(lngSimbolPos)
  Case 73 '"I" eng
   If fNextCyr And fPrevCyr Then bNewCode = 178
  Case 105 '"i" eng
   If fNextCyr And fPrevCyr Then bNewCode = 179
  Case 178 '"I" cyr
   If fNextEng And fPrevEng Then bNewCode = 73
  Case 179 '"i" cyr
   If fNextEng And fPrevEng Then bNewCode = 105
  Case 67 '"C" eng
' 67, 99, 209, 241
   If fNextCyr And fPrevCyr Then bNewCode = 209
  Case 99 '"c" eng
   If fNextCyr And fPrevCyr Then bNewCode = 241
  Case 209 '"C" cyr
   If fNextEng And fPrevEng Then bNewCode = 67
  Case 241 '"c" cyr
   If fNextEng And fPrevEng Then bNewCode = 99
 End Select
 If bNewCode > 0 Then
    bArr(lngSimbolPos) = bNewCode
    ChangeIiCcLangInArray = True
 End If

ChangeIiCcLangInArray_exit:
    Exit Function
ChangeIiCcLangInArray_err:
    Resume ChangeIiCcLangInArray_exit
End Function

BP(R) DBF для VB6
(c) BASIC Production 27/03/2005

Класс для работы с файлами формата DBF.

Содержание
----------
1. Введение.
2. Подключение класса.
3. Создание, открытие и закрытие базы.
4. Работа с несколькими базами одновременно.
5. Функции обслуживания базы данных.

1. Введение.
------------
 Файл формата DBF является базой данных. Состоит он из заголовка, описателей полей и записей. В классе BPDBF записи обозначаются как ряды(Rows), а поля как колонки(Cols или Columns). Каждая запись состоит из фиксированного количества полей фиксированный длины, что свидетельствует о постоянном размере записи независимо от её значения.
 1. Заголовок - служебная информация
 2. Описатель полей - информация о полях в записи
 3. Записи - Поле/Поле/.../Поле
 В заголовке хранится служебная информация; в описателях полей имена, типы и длины каждого поля в записи; а в самой записи - непосредственно значения. Стурктуру базы можно представить как таблицу с фиксированным количеством колонок и неограниченным количеством рядов. Например если вы создали базу данных и в описателе полей у вас описано два поля, то все записи в базе будут иметь два поля.
 Каждое поле имеет свой тип данных, который указывается в описателе полей. Эти типы влияют на поля в записях.
 Запись - Поле Типа1/Поле Типа2/.../Поле ТипаN
Поля следующих типов могут быть в базе данных:
 - Строка; поле может иметь любую длину
 - Дата; фиксированной длины (8 символов) в формате ГГГГММДД
 - Дробное число; двоичное представление дробного числа
 - Логический; ? Y y N n T t F f (? - не инициализировано)
 - Мемо; фиксированной длины (10 символов), содержат номер 512-байтного блока в индексном файле
 - Числовой; целые числа в десятичном представлении (-.0123456789).

2. Подключение класса
---------------------
Добавьте в проект модуль BPDBF.CLS.
В модуле формы объявите объектную переменную ссылкой на класс:
 Private MyDBF As BPDBF
В форме (например в Form_Load) создайте новый экземпляр класса:
 Set MyDBF = New BPDBF
Подключение совершено. Для обращения к методам и свойствам объекта введите имя переменной и нажмите точку.
 MyDBF.

3. Создание, открытие и закрытие базы.
--------------------------------------
3.1 Создание базы.
 Перед созданием базы необходимо предварительно создать колонки (поля) записи с помощью метода AddColumn, в противном случае база не будет создана.
 MyDBF.EraseColumns
 MyDBF.AddColumn "Column 1", N_Decimal, 1
 MyDBF.CreateDBF "Test1.DBF"
В этом примере будет создана база в которой каждая запись будет содержать одно поле в числовом формате длиной 1 байт.

3.2 Открытие базы
 MyDBF.OpenDBF "ИмяБазы"

3.3 Закрытие базы
 MyDBF.CloseDBF

4. Работа с несколькими базами одновременно.
--------------------------------------------
 Построение класса BPDBF позволяет работать одновременно только с одним файлом базы данных. Для одновременной работы с несколькими базами создайте необходимое количество объектных переменных.
 Private MyDBF As BPDBF, MyDBF2 As BPDBF
 Private Sub Form_Load()
  Set MyDBF = New BPDBF: Set MyDBF2 = New BPDBF
 End Sub

5. Функции обслуживания базы данных.
------------------------------------
 Ниже перечислены функции обслуживания базы данных по группам.

5.1. Функции работы с описателем полей. Эти функции доступны только при закрытой базе.
 AddColumn - добавляет информацию о новом поле в описатель полей.
  Параметры:
Caption - Имя (до 11 символов)
ColType - поддерживаемый тип данных
Length - длина поля
DecimalCount - длина дробной части после точки
 RemoveColumn - уменьшает счётчик полей в описателе полей на 1.
 ResetColumns - сбрасывает счётчик полей в описателе полей без очистки самих полей.
 EraseColumns - очищает описатель полей.

5.2. Подготовительные и завершающие функции.
 CreateDBF - создаёт пустую базу данных.
  Параметры: FileName - имя файла для новой базы
 OpenDBF - открывает существующую базу данных
  Параметры: FileName - имя файла базы данных
 CloseDBF - закрывает открытую ранее базу данных.

5.3. Работа с записями.
 AddEmptyRows - добавляет указанное количество пустых записей в базу.
 AddRow - добавляет одну запись в базу
  Параметры: RowCols - строка, содержащая значение записи. Например если запись состоит из 3-х полей длиной 1,2 и 3 байта, то в строке должны быть в первом символе - значение поля1, следующие 2 символа - поля2 и следующие 3 символа - поля3.
 eleteRow - помечает (или снимает пометку) запись как удалённую
  Параметры:
RowNumber - Номер записи
DeleteFlag - Истина - установить пометку на удаление; Ложь - снять пометку
 GetRow - получить строку записи
  Параметры:
RowNumber - номер записи
UseOEM - переводить из кодировки ДОС в Windows
 GetRowCols - получить в массив все поля записи
  Параметры:
ColumnsArray() - любой строчный массив-приёмник
RowNumber - номер записи
UseOEM - переводить из кодировки ДОС в Windows
 GetColumn - получить поле записи по номеру поля
  Параметры:
RowNumber - номер записи
ColNumber - номер поля в записи
UseOEM - переводить результат из кодировки OEM в Windows
 ReplaceRow - заменить значение поля на новое
  Параметры:
RowNumber - номер записи
Value - значение записи
UseOEM - переводить из кодировки Windows в ДОС
 ReplaceRowCols - заменить все поля записи на новые из массива
  Параметры:
ColumnsArray() - строчный массив-источник
RowNumber - номер записи
UseOEM - переводить из кодировки Windows в ДОС
 ReplaceColumn - заменить значение поля в записи
  Параметры:
RowNumber - номер записи
ColNumber - номер поля
Value - новое значение

5.4. Информационные и служебные
 atabaseName - возвращает имя открытой базы;
 IsDbfOpen - возвращает истину если база открыта;
 RowsCount - возвращает количество записей в базе;
 ColumnsCount - возвращает количество полей в записи;
 GetColName - возвращает имя поля (из описателя полей) по указанному индексу;
 GetColSize - возвращает длину поля по указанному индексу;
 GetColType - возвращает тип поля по указанному индексу;
 IsRowDeleted - возвращает наличие отметки удаления в записи;
 efrag - физически удаляет помеченные на удаление записи;