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

Использование Application.FileSearch поможет Вам найти файлы на диске. Для Office 2007 эта функция не работает. Можно использовать другие функции, типа Dir, FileSystemObject и т.п.

' Поиск файлов по шаблону
Private Sub butRead_Click()
Dim i As Long
On Error GoTo 999
    With Application.FileSearch
       .NewSearch
       .LookIn = Me.myFolder ' = c:\
       .FILENAME = Me.myExt ' = *.mdb
       .SearchSubFolders = Me.myFflagSubFolder ' = True
       If .Execute(SortBy:=msoSortByFileName, _
                SortOrder:=msoSortOrderAscending)  0 Then
            Me.progress = "Count="  .FoundFiles.Count  vbCrLf
            For i = 1 To .FoundFiles.Count
                Me.progress = Me.progress  .FoundFiles(i)  vbCrLf
            Next i
       End If
    End With
    Exit Sub      'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

01. ADO и DAO - два разных метода доступа к данным реализованы в этом примере. Используйте этот пример для создания новых баз данных из Access. ADOX - это библиотека расширенных функций базы данных.

'==============================================================
' ADOX. Создание базы данных
Private Sub butADO_Click()
Dim cat As New ADOX.Catalog, strmdb As String
    
    ' Определение файла
    strmdb = Application.CurrentProject.Path  "\temp.mdb" ' Путь базы
    If Dir(strmdb)  "" Then Kill strmdb 'Уничтожаем старую базу данных
    
    ' ADOX. Создание базы
    cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="  strmdb
    Set cat = Nothing
    MsgBox "База создана (ADOX)!", vbExclamation, "Лидер Access"
   
   ' Удаление базы
   If Dir(strmdb)  "" Then Kill strmdb 'Уничтожаем старую базу данных
End Sub

'==============================================================
' DAO. Открытие базы данных
Private Sub butDAO_Click()
Dim dbs As DAO.Database, strmdb As String
   
   ' Определение файла
   strmdb = Application.CurrentProject.Path  "\temp.mdb" ' Путь базы
   If Dir(strmdb)  "" Then Kill strmdb 'Уничтожаем старую базу данных
   
   ' DAO. Открываем на чтение
   DBEngine.CreateDatabase strmdb, dbLangCyrillic
   MsgBox "База создана (DAO)!", vbExclamation, "Лидер Access"
   
   ' Удаление базы
   If Dir(strmdb)  "" Then Kill strmdb 'Уничтожаем старую базу данных
End Sub

01. Dictionary - этот объект можно использовать для создания массивов, даже для форм. Таким образом можно создать интерфейс, который будет открывать 2 одинаковые формы, что в Access нереально создать обычным способом.

'==============================================================
'   Использование массива Dictionary для таблицы
Public Function funArrayDictionary() As String
Dim s As String, i  As Integer, dbs As Database, rst As Recordset
Dim myArray, myBooks 'Переменные для массива
   
    On Error GoTo 999 'Обработка ошибки

'1.Открытие таблицы
    Set dbs = CurrentDb 'Выбираем базу данных
    Set rst = dbs.OpenRecordset("SELECT * FROM [Мои книги]") 'Создаем запрос
    If (rst.RecordCount = 0) Then 'Проверяем таблицу
        rst.Close 'Закрываем запрос
        MsgBox "Нет данных" 'Сообщаем об этом
        Exit Function
    End If

'2. Заполнение запроса
    rst.MoveLast
    rst.MoveFirst
    
'3. Заполнение массива
    Set myArray = CreateObject("Scripting.Dictionary") 'Создаем массив
    myArray.RemoveAll 'Удаляем все
    For i = 0 To rst.RecordCount - 1
          myArray.Add CStr(rst!Ключ), CStr(rst!Книга) 'Добавляем значение в массив
          rst.MoveNext 'переходим на следующую запись
    Next i

'4. Проверка массива
    myBooks = myArray.Items        'Выбираем все книги
    For i = 0 To myArray.Count - 1 'Создаем цикл
        s = s  myBooks(i)  vbCrLf  'Создаем список книг
    Next
    funArrayDictionary = s 'Возвращаем список

'5. Конец примера
    myArray.RemoveAll 'Удаляем массив
    rst.Close
    Set dbs = Nothing '!Внимание. Посылаем ... переменную!
    Exit Function
999:
    MsgBox Err.Description
    Err.Clear
    rst.Close
End Function

01. Это простейший пример для работы с шрихкодом. Как его создать, используя функции рисования, в Access или ASP.NET используйте специальные комменческие программы на этом сайте.

01. В этот примере вы видите, как можно использовать оператор GoTo для сообщения об ошибке. Она записывается в переменную Err.

Private Sub butRead_Click()
On Error GoTo 999 ' В случае возникновения ошибки перейти на метку 999
Dim a As Long
    a = Eval(Me.myEval)
    MsgBox "Результат: "  a, vbInformation, "Результат вычисления"
    Exit Sub 'Выходим из программы
999:
    MsgBox "Номер ошибки: "  Err.Number  vbNewLine  "Описание ошибки: "  Err.Description, vbCritical, "Ошибка в программе"
    Err.Clear 'Очищаем поток от ошибок
End Sub

01. Данный пример показывает Вам техническое решение, которое может использоваться для бинарного редактирования файлов Access. Цель решения сравниванить по битно 2 файла: зашифрованный и нет. Таким образом, Вы сможете найти область изменения файла, где хранится ее пароль. Данное утверждение верно, только для некоторых версий Access.

Option Compare Database
Option Explicit

'***************************************************************
'Пример 1:   Удаление/установка пароля базы Данных /04.09.2000/
'***************************************************************

Dim pwdFree, pwdOne 'Массивы переменных, сохраняющих пароли

'==============================================================
'Название
'   Пример 1. Инициализация данных
Private Sub Form_Open(Cancel As Integer)
    'Нет пароля, пример шестнадцатиричной записи
    pwdFree = Array(H86, HFB, HEC, H37, H5D, H44, _
                    H9C, HFA, HC6, H5E, H28, HE6, H13)
    'Пароль 1, пример десятичной записи
    pwdOne = Array(183, 251, 236, 55, 93, 68, _
                   156, 250, 198, 94, 40, 230, 19)
    
    'Значение файла в форме, назначаемое по умолчанию
    Me.myAccessFile.DefaultValue = "'"  funGetAppFolder  "\la_prot97.mdb"  "'"
    
    'Максимализировать приложение
    Application.DoCmd.RunCommand acCmdAppMaximize
End Sub

'==============================================================
'Название
'   Пример 1. Показать пароль
Private Sub butPassword_Click()
Dim s As String
    MsgBox "Файл: "  Me.myAccessFile  Chr(13)  funReadHead(Me.myAccessFile), vbInformation, "Пароль файла"
End Sub

'==============================================================
'Название
'   Пример 1. Удалить пароль
Private Sub butDelPassword_Click()
    funSetPassword 0, "Пароль удален!"
End Sub

'==============================================================
'Название
'   Пример 1. Установить пароль
Private Sub butSetPassword_Click()
    funSetPassword 1, "Установлен пароль: 1"
End Sub

'==============================================================
'Название
'   Пример 1. Прочитать заголовок пароля
Private Function funReadHead(myFile As String) As String
Dim i As Integer, ID As Byte, pwd(12) As Byte
    On Error GoTo 999
    'Часть заголовка не защищенного файла
        ID = FreeFile 'Получить свободный идентификатор файла
        Open myFile For Binary As ID 'Открываем файл
        funReadHead = ""
        For i = 0 To 12
            Get #ID, 67 + i, pwd(i) 'Читаем пароль
            funReadHead = funReadHead  Format(pwd(i), "000")  ","
        Next i
        Close 'Закрываем открытые файлы
    Exit Function
999:
    MsgBox Err.Description
End Function

'==============================================================
'Название
'   Пример 1. Изменить пароль
Private Sub funSetPassword(myFlag As Integer, myMsg As String)
Dim i As Integer, ID As Byte
    On Error GoTo 999
 
    If MsgBox("Изменить пароль файла ?", vbOKCancel + vbExclamation, "Изменение пароля") = vbOK Then
        ID = FreeFile 'Получить свободный идентификатор файла
        Open Me.myAccessFile For Binary As ID 'Открываем файл в двоичном виде
        For i = 0 To 12
            Select Case myFlag 'Выбираем режим установки
            Case 0: Put #ID, 67 + i, CByte(pwdFree(i)) 'Удаляем пароль
            Case 1: Put #ID, 67 + i, CByte(pwdOne(i))  'Записываем пароль 1
            End Select
        Next i
        Close 'Закрываем открытый файл
        MsgBox myMsg, vbInformation, "Изменение пароля" 'Сообщение
    End If
    
    Exit Sub
999:
    MsgBox Err.Description
End Sub

'==============================================================
'Название
'   Пример 1. проверить существование файла
Private Sub myAccessFile_AfterUpdate()
    If Dir(Me.myAccessFile) = "" Then
        MsgBox "Файл: "  Me.myAccessFile  " не существует!"
    End If
End Sub

'==============================================================
'Название
'   Пример 1. Открыть базу данных
Private Sub butView_Click()
      Application.FollowHyperlink Me.myAccessFile, , True
End Sub

'==============================================================
'Название
'   Пример 1. Прочитать папку (см. Лекции Access 2000)
Public Function funGetAppFolder() As String
Dim fs
    On Error GoTo 999  'Назначаем переход по ошибке
    Set fs = CreateObject("Scripting.FileSystemObject") 'Создаем файловую систему
    funGetAppFolder = fs.GetFile(CurrentDb.Name).ParentFolder 'Находим папку
    Set fs = Nothing 'Уничтожаем переменную
    Exit Function 'Выходим из программы
999:
    MsgBox Err.Description 'Сообщаем об ошибке
    Err.Clear 'Очищаем поток от ошибок
End Function

Данный пример показывает как можно создать календарь, используя ActiveX Calendar от Microsoft. Поставьте ссылку на C:\Program Files\Microsoft Office\OFFICE11\MSCALL.OCX. Применяется класс для создания календаря.

Option Compare Database
Option Explicit

Public WithEvents CurrentCal As MicrosoftCal

'   Настройка календаря
Private Sub Form_Load()
    Set CurrentCal = New MicrosoftCal
    Set CurrentCal.Cal = Me.myCal.Object
    With Me.CurrentCal.Cal ' Настройка календаря
        '.Value = Date ' Установка текущей даты
        .TitleFontColor = 255 ' Цвет заголовка
        .Year = Year(Date) ' Устанавливаем год
        .Month = Month(Date) ' Устанавливаем месяц
        .Day = Day(Date) ' Уставливаем день
        .NextDay ' Следующий день
        '.ShowTitle = False ' Гасим заголовок
        ' Введите точку и установите параметр
    End With
End Sub

'   Добавим событие-сообщение для нового класса
Public Sub CurrentCal_Progress(myMsg As String)
    If Me.butEvents Then
        Me.myEvents = myMsg  vbNewLine  Me.myEvents
        DoEvents
    End If
End Sub

'   Установлена дата
Public Sub myCal_AfterUpdate()
    'CurrentCal_Progress "Date: "  Me.myCal
End Sub

'   События для формы
Private Sub myCal_GotFocus()
    CurrentCal_Progress "GotFocus"
End Sub
Private Sub myCal_LostFocus()
    CurrentCal_Progress "LostFocus"
End Sub
Private Sub butEvents_AfterUpdate()
    Me.myEvents = ""
End Sub

'==============================================================

' Объявляем класс Calendar
Public WithEvents Cal As Calendar

' Объявляем событие для сообщений
Public Event progress(strMsg As String)

'==============================================================
'  События при создании/уничтожении класса
Private Sub Class_Initialize()
   ' Инициализация
End Sub
Private Sub Class_Terminate()
   ' Сохраняем данные
End Sub

'==============================================================
'  События до/после редактирования метки узла
Private Sub Cal_AfterUpdate()
   funPrintEvent "AfterUpdate: "  Me.Cal.Value
End Sub
Private Sub Cal_BeforeUpdate(Cancel As Integer)
   funPrintEvent "BeforeUpdate: "  Me.Cal.Value
End Sub
Private Sub Cal_NewMonth()
   funPrintEvent "NewMonth: "  Me.Cal.Value
End Sub
Private Sub Cal_NewYear()
   funPrintEvent "NewYear: "  Me.Cal.Value
End Sub

'==============================================================
'  События мышки
Private Sub Cal_Click()
   funPrintEvent "Click"
End Sub
Private Sub Cal_DblClick()
   funPrintEvent "DblClick"
End Sub

'==============================================================
'  События клавиатуры
Private Sub Cal_KeyDown(KeyCode As Integer, ByVal Shift As Integer)
   funPrintEvent "KeyDown (KeyCode: "  KeyCode  ", Shift = "  Shift  ")"
End Sub
Private Sub Cal_KeyPress(KeyAscii As Integer)
   funPrintEvent "KeyPress: "  KeyAscii
End Sub
Private Sub Cal_KeyUp(KeyCode As Integer, ByVal Shift As Integer)
    funPrintEvent "KeyUp (KeyCode: "  KeyCode  ", Shift = "  Shift  ")"
End Sub

'==============================================================
'   Функция сообщающая о получении событий
Private Function funPrintEvent(myMsg As String)
    RaiseEvent progress(myMsg) ' Генерируем событие для узла
End Function

Возможно Вам придется из программы регистрировать некоторые ActiveX Элементы. Этот пример показывает, как можно создать регистрацию элемента из Access, а также как можно ее удалить.

'  Проверка ссылок в таблице (дополнительная функция)
'
Private Sub Form_Open(Cancel As Integer)
Dim ref As Reference, i As Long
Dim dbs As DAO.Database, rst As DAO.Recordset
Dim strName As String
    
    On Error Resume Next
    ' Определяем свою папку OCX для ActiveX
    Me.myFolder = Application.CurrentProject.Path  "\ocx"
    
    ' Инициализируем таблицу
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("SELECT * FROM [Example 01] WHERE [myRef]=True")
    
    ' Просматриваем все ссылки
    rst.MoveLast
    rst.MoveFirst
    For i = 0 To rst.RecordCount - 1
        strName = rst!Name
        Set ref = Application.References(strName)
        rst.Edit
        If ref Is Nothing Then
            Err.Clear
            rst!Path = "Файл не найден!"
        Else
            rst.Edit
            rst!Path = CStr(ref.FullPath)
            rst!Ver = CStr(ref.Major)  "."  CStr(ref.Minor)
            Set ref = Nothing
        End If
        rst.Update
        rst.MoveNext
   Next
    rst.Close
    Set dbs = Nothing
    
    ' Обновляем таблицу
    Me.[01 RegActiveX_sub].Requery
    Exit Sub
999:
    MsgBox Err  ": "  Err.Description
    Err.Clear
    Resume Next
End Sub

'  Регистрация элементов
Private Sub butReg32_Click()
Dim ref As Reference, i As Long, strName As String
Dim dbs As Database, rst As Recordset
Dim strOcx As String

    On Error GoTo 999
    Set dbs = CurrentDb
    
    ' Определяем свою папку OCX для ActiveX
    Me.myFolder = Application.CurrentProject.Path  "\OCX"
    
    ' Инициализируем таблицу
    Set rst = dbs.OpenRecordset("SELECT * FROM [Example 01] WHERE [Path]='Файл не найден!'")
    On Error Resume Next
    
    ' Изменяем ссылки
    rst.MoveLast
    rst.MoveFirst
    For i = 0 To rst.RecordCount - 1
        strOcx = Me.myFolder  "\"  rst!File
        If Dir(strOcx)  "" Then ' Файл существует
            funRegsvr32 strOcx, "" ' Регистрируем ActiveX
            rst.Edit
            rst!Path = strOcx
            rst.Update
        Else
            MsgBox "Файл "  strOcx  " не найден!"
        End If
        rst.MoveNext
    Next
    Set dbs = Nothing
    Me.[01 RegActiveX_sub].Requery
    Exit Sub
999:
    MsgBox Err  ": "  Err.Description
    Err.Clear
End Sub

'   Регистрация ActiveX элемента в OC
'       regsvr32.exe  a.ocx   ' регистрация ActiveX
'       regsvr32.exe -u a.ocx ' отмена регистрации
'   Параметры
'       strFlag = "" или "-u"
'
Public Sub funRegsvr32(strOcx As String, strFlag As String)
Dim fs, strExe As String, strSysFolder
    On Error GoTo 999
    
    Set fs = CreateObject("Scripting.FileSystemObject") 'Создаем файловую систему
    
    ' Определяем системную папку
    strSysFolder = fs.GetSpecialFolder(1)
    strExe = strSysFolder  "\regsvr32.exe"  ' Составляем exe файл
    If Dir(strExe)  "" Then ' Проверяем exe-файл
       If Dir(strOcx)  "" Then
            ' Копируем в системную папку (не так важно)
            'fs.CopyFile strOcx, strSysFolder  "\"
            'strOcx = strSysFolder  "\"  fs.GetFileName(strOcx) ' Системный файл
            
            ' 1 способ
            If strFlag  "-u" Then
                References.AddFromFile strOcx
            Else
                ' Удаление регистрации
                'Dim ref As Reference
                'Set ref = References(strOcx)
                'References.Remove ref
            End If
            
            ' 2 способ. Регистрация/Удаление
            'strExe = strExe  " "  strFlag  " """  strOcx  """"
            'Shell strExe, vbHide 'Запускаем программу
       Else
            MsgBox "Нет файла: "  strOcx
       End If
    Else
       MsgBox "Нет файла: "  strExe
    End If
    Set fs = Nothing
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

08. Этот пример показывает как с использованием API интерфейса получить текущее и сетевое имя пользователя в Windows. Можно использовать для определения MSDE на текущей машине.

Private Declare Function apiGetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long


' Возвращает сетевое имя пользователя
Function funGetUserName() As String
Dim BufSize As Long, strUserName As String * 255, status As Long
    On Error GoTo 999
        BufSize = 255
        status = apiGetUserName(strUserName, BufSize)
        If status = 1 Then
            funGetUserName = Left$(strUserName, InStr(strUserName, Chr(0)) - 1)
        Else
            funGetUserName = ""
        End If
    Exit Function
999:
    MsgBox Err.Description
End Function

' Функция запуска событий
Private Sub butExec_Click()
    Me.msg = "Локальное имя: "  funGetUserName  vbNewLine  _
             "Сетевое имя: "  NetUserID
End Sub

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

'Const alfaAnsi As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ^abcdefghijklmnopqrstuvwxyz~"
Const alfaWin As String = "абвгдеёжзийклмнопрстуфхцчшщьэъюяАБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЬЭЪЮЯ№ыЫ"
Const alfaDos As String = " ЎўЈ¤Ґс¦§Ё©Є«¬­®ЇабвгдежзиймнкопЂЃ‚ѓ„…р†‡€‰Љ‹ЊЌЋЏђ‘’“”•–—˜™њќљћџьл›"

' Заголовок, прочитанный в буфер
Public Type dbfBufHeader
    buf As String * 4 ' Номер версии и дата
    RecordCount As Long ' Число записей
    HeaderLength  As Integer ' Длина заголовка
    RecordLength  As Integer ' Длина записи
End Type

' Характеристика поля базы данных
Public Type dbfFields
    Name   As String ' Название поля
    Type   As String ' Тип поля
    Length As Integer ' Длина поля
    Dec    As Integer ' Число знаков после запятой
End Type

' Данные по записи
Public Type dbfRecord
    Mark   As String ' 1 байт. Флаг маркировки: * - удалена или " "
    Data() As String ' Данные всех полей
End Type

' Полная информация по заголовку
Public Type dbfHeader
    VersionNumber As Integer ' Номер версии
    LastUpdate    As Date ' Дата последнего обновления
    HeaderLength  As Integer ' Длина заголовка
    RecordCount   As Long ' Число записей
    RecordLength  As Integer ' Длина записи
    NumberFields  As Integer ' Число полей
    FileSize      As Long ' Размер файла
    PathDBF       As String ' Имя файла
    PathDBT       As String ' Имя файла
    TableAccess   As String ' Таблица в Mdb файле
    Fields()      As dbfFields ' Данные по полям
    Record        As dbfRecord ' Информация по 1 записи
    DBF As Integer ' Указатель на DBF файл
    DBT As Integer ' Указатель на MEMO файл
End Type

'==============================================================
'   Прочитать данные о заголовке dbf файла
'   и сохранить данные в структуре hDbf
'
Function dbfReadHeader(hDbf As dbfHeader, strPath As String, strTableAccess As String) As Long
Dim bufHdr As dbfBufHeader ' Заголовок - буфер
    hDbf.DBF = FreeFile()  ' Создаем указатель
    With hDbf
        Open strPath For Binary As #.DBF
        Get #.DBF, , bufHdr ' Читаем заголовок
        .PathDBF = strPath
        .TableAccess = strTableAccess
        .VersionNumber = Asc(Left$(bufHdr.buf, 1)) And (7) ' Номер версии
        .LastUpdate = dbfReadDate(Mid$(bufHdr.buf, 2, 3)) ' Дата
        .RecordCount = bufHdr.RecordCount ' Число записей
        .HeaderLength = bufHdr.HeaderLength ' Длина заголовка
        .RecordLength = bufHdr.RecordLength ' Длина записи
        .NumberFields = (hDbf.HeaderLength - 33) / 32 ' Число полей
        .FileSize = 1 + .HeaderLength + .RecordLength * .RecordCount ' Длина файла
    
        ' Проверка версии
        If .VersionNumber  3 Then
           dbfReadHeader = -1   ' Это не DBase Файл
           Exit Function
        End If
    
        ' Проверка числа записей
        If .RecordCount = 0 Then
           dbfReadHeader = -2  ' Нет записей
           Exit Function
        End If
    
        ' Меняем в заголовке число полей
        ReDim .Fields(.NumberFields - 1)
        ' Выделяем память для данных 1 записи
        ReDim .Record.Data(.NumberFields - 1)
    End With
    
    ' Нет ошибок
    dbfReadHeader = 0
End Function

'==============================================================
'   Прочитать данные из заголовка
'   о полях: Имя, Тип, Длина, Дес. точка
'
Function dbfReadNameFields(hDbf As dbfHeader) As Long
Dim i As Long, buf As String, hEof As String
    With hDbf
        Seek #.DBF, 33 ' Устанавливаем позицию
        buf = Space$(32) ' Выделяем память
        For i = 0 To .NumberFields - 1
           Get #.DBF, , buf   ' Читаем строку длиной 32 байта
           .Fields(i).Name = Trim(dbfTrimString(Left$(buf, 11), 11))
           .Fields(i).Type = Mid$(buf, 12, 1)
           .Fields(i).Length = Asc(Mid$(buf, 17, 1))
           .Fields(i).Dec = Asc(Mid$(buf, 18, 1))
        Next i
        hEof = Input$(1, #.DBF)  ' Конец заголовка
        If Asc(hEof)  13 Then
           dbfReadNameFields = False  ' Плохой заголовок
        Else
           dbfReadNameFields = True ' Правильная структура
        End If
    End With
End Function

'==============================================================
'   Сохраняем данные о полях в таблице
'
Function dbfSaveNameFields(hDbf As dbfHeader) As Long
Dim i As Long, s As String
Dim dbs As DAO.Database, tdf As DAO.TableDef
    
    With hDbf
        ' Удаляем ненужную таблицу
        On Error Resume Next
        DoCmd.DeleteObject acTable, .TableAccess
        Err.Clear
        
        ' Создаем поля
        Set dbs = CurrentDb
        Set tdf = dbs.CreateTableDef(.TableAccess)  'Создаем таблицу
        For i = 0 To .NumberFields - 1
            s = .Fields(i).Name
            Select Case .Fields(i).Type
            Case "C":  tdf.Fields.Append tdf.CreateField(s, dbText, hDbf.Fields(i).Length)
            Case "D":  tdf.Fields.Append tdf.CreateField(s, dbDate)
            Case "F":  tdf.Fields.Append tdf.CreateField(s, dbFloat)
            Case "M":  tdf.Fields.Append tdf.CreateField(s, dbMemo)
            Case "L":  tdf.Fields.Append tdf.CreateField(s, dbBoolean)
            Case "N":
                    tdf.Fields.Append tdf.CreateField(s, dbDouble)
    '            If .Fields(i).Dec = 0 Then
    '                tdf.Fields.Append tdf.CreateField(s, dbLong)
    '            Else
    '            End If
            End Select
        Next i
    End With
    dbs.TableDefs.Append tdf 'Добавляем таблицу
End Function

'==============================================================
'   Прочитаем 1 запись в базу данных
'
Sub dbfReadRecord(hDbf As dbfHeader, NumRec As Long)
Dim buf As String, pos As Long, i As Long
Dim ss As String, p As Long
    
    With hDbf
        ' Выделяем память
        buf = Space$(.RecordLength)
        ' Находим позицию
        Seek #.DBF, 1 + .HeaderLength + (NumRec - 1) * .RecordLength
        ' Читаем запись
        Get #.DBF, , buf
        ' Чтение метки удаления "*" и " "
        .Record.Mark = Left(buf, 1)
        ' Установка позиции
        pos = 2
        ' Разбор данных
        For i = 0 To .NumberFields - 1
           ' Выбор полей
           ss = Mid(buf, pos, .Fields(i).Length)
           ss = dbfTrimString(ss, CLng(.Fields(i).Length))
           
           ' Настройка некоторых полей
           Select Case hDbf.Fields(i).Type
              Case "D" ' dd/mm/yyyy
                 ss = Right$(ss, 2) + "/" + Mid$(ss, 5, 2) + "/" + Left$(ss, 4)
              Case "L" ' Логическое поле T,Y или F,N
                  Select Case UCase$(ss)
                     Case "Y", "T": ss = "True"
                     Case "N", "F": ss = "False"
                     Case Else: ss = "?"
                  End Select
              Case Else
           End Select
           ' Назначаем данные
           .Record.Data(i) = ss
           ' Определяем позицию следующего поля
           pos = pos + .Fields(i).Length
        Next i
    End With
End Sub

'==============================================================
'   Сохраняем данные 1 записи в таблице
'
Function dbfSaveRecord(hDbf As dbfHeader) As Long
Dim i As Long, p As Long, dbs As Database, rst As DAO.Recordset, buf As String, sn As String
    On Error GoTo 999
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(hDbf.TableAccess)
    With hDbf
        rst.AddNew
        For i = 0 To .NumberFields - 1
            buf = .Record.Data(i) ' Nz(Trim(.Record.Data(i)), " ")
            sn = .Fields(i).Name
            Select Case .Fields(i).Type
            Case "C":  rst(sn).Value = CStr(buf)
            Case "D":  rst(sn).Value = CDate(buf)
            Case "M":  rst(sn).Value = buf
            Case "L":  rst(sn).Value = CBool(buf)
            Case "N", "F":
                p = InStr(buf, ".")
                If p Then buf = Left(buf, p - 1)  ","  Mid(buf, p + 1)
                rst(sn).Value = CDbl(buf)
            End Select
        Next i
        rst.Update
    End With
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Exit Function
999:
    Err.Clear
    Resume Next
End Function

'==============================================================
'   Программа для конвертации строки из Dos в Windows и наоборот
'
Public Function dbfReadDate(buf As String) As Date
On Error Resume Next
    dbfReadDate = DateValue( _
        1900 + Asc(Mid$(buf, 1, 1))  "/"  _
        Asc(Mid$(buf, 2, 1))  "/"  _
        Asc(Mid$(buf, 3, 1)))
    Err.Clear
End Function

'==============================================================
'   Программа для конвертации строки из Dos в Windows и наоборот
'
Public Function dbfStrConv(strData As String, buf1 As String, buf2 As String) As String
Dim i As Long, strChar As String, p As Long
    
    ' Конвертирование строки
    dbfStrConv = ""
    For i = 1 To Len(strData)
        strChar = Mid(strData, i, 1)
        p = InStr(1, buf1, strChar)
        If p  0 Then
            dbfStrConv = dbfStrConv  Mid(buf2, p, 1)
        Else
            dbfStrConv = dbfStrConv  strChar
        End If
    Next
End Function

'==============================================================
'   Обрезаем ненужные данные из строки dbf
'
Public Function dbfTrimString(strData As String, lngData As Long) As String
Dim p1 As Long, p2 As Long
    ' Конвертируем строку из Dos в Windows
    strData = dbfStrConv(strData, alfaDos, alfaWin)
    ' Определяем пустые данные
    For p1 = 1 To lngData
        If Asc(Mid(strData, p1, 1)) = 32 Then Exit For
    Next
    For p2 = p1 To lngData
        If Asc(Mid(strData, p2, 1))  32 Then Exit For
    Next
    dbfTrimString = Mid(strData, p1, p2 - p1)
End Function