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

03. Данный пример показывает как можно быстро создать документ Word из Microsoft Access, используя шаблон *.dot. Для разметки документа используются специальные закладки.

'==============================================================
'   Создание документа Word по шаблону
'   • Для этого Вы должны создать в Word шаблон la_automat.dot
'   и поставить в нем Закладки, имеющие такие же имена как в форме.
'   Например, Вставка - Закладка ... - Имя закладки=Фирма
'   (Нажмите кнопку Добавить и сохраните шаблон)
'
Private Sub butNewWord_Click()
Dim app As Word.Application  'Приложение программы
Dim strDOC As String ' Имя документа
Dim strDOT As String ' Имя шаблона
Dim ctl As Control ' Управляющие элементы в форме
Dim s As String ' Вспомогательная строка
    
    On Error GoTo 999
    ' Определяем имена шаблона и документа Word
    With Application.CurrentProject
        strDOT = .Path  "\"  "la_automat.dot"
        strDOC = .Path  "\"  "la_automat.doc"
    End With
    
    ' Управление документом Word
    Set app = New Word.Application 'Новое приложение Word
    app.Visible = True 'Отображаем документ
    app.Documents.Add strDOT 'Добавляем шаблон
    With app.ActiveDocument  'Выбираем активный документ
        On Error Resume Next ' Отключаем ошибки
        ' Просматриваем все элементы формы, если
        ' такой закладки нет, то очищаем поток от ошибки
        For Each ctl In Me.Controls
            If ctl.ControlType = acTextBox Then
                s = ctl.Name ' Определяем название элемента
                .Bookmarks.Item(s).Range.Text = Me(s) 'Устанавливаем текст
                Err.Clear ' Очищаем поток от ошибки при отсутствии элемента
            End If
        Next ctl
        .SaveAs strDOC ' Сохраняем файл
        On Error GoTo 999 ' Включаем обработку ошибки
    End With
    ' app.Quit 'Закрываем приложение
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
    app.Quit
End Sub

02. Данный пример показывает как можно быстро создать документ Word из Microsoft Access. При этом документ будет создаваться в текущей папке, откуда запущено приложение. Также не забудьте создать ссылку на Word: C:\Program Files\Microsoft Office\OFFICE11\MSWORD.OLB

'==============================================================
'  Назначение
'    Создать документ Word в текущей папке
'
Private Sub butExecute_Click()
Dim app As Word.Application  ' Приложение программы
Dim strDOC As String ' Имя файла
    On Error GoTo 999
    ' Назначаем имя документа
    strDOC = Application.CurrentProject.Path  "\"  "la_automat.doc"
    Set app = New Word.Application ' Создаем документ
    app.Visible = False ' Скрываем документ
    app.Documents.Add ' Добавляем документ
    app.Selection.Text = Me.Body ' Вставляем текст
    app.ActiveDocument.SaveAs strDOC ' Сохраняем документ
    app.Quit ' Закрываем документ
    MsgBox "Файл: "  strDOC  " создан!", vbExclamation, "Документ Word"
    ' Назначение ссылки
    With Me.myWordDoc
        .HyperlinkAddress = strDOC ' Создаем ссылку
        .Visible = True ' Отображаем элемент
    End With
    Exit Sub
999:
    MsgBox Err.Description  ' Ошибка
    Err.Clear
    app.Quit
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

05. Этот пример показывает как с использованием API интерфейса и других действий изменять главное окно Access.

' Константы отображения
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10

' Функция управляет отображением окна
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" _
    (ByVal hWnd As Long, _
     ByVal nCmdShow As Long) As Long

' Команды в котором создаются приложения
Dim appAcc As Access.Application

'  Отобразить окно
Private Sub butON_Click()
Dim s As String
    On Error Resume Next
    ' Выход из приложения
    Form_Close
    
    ' Открываем окно
    Set appAcc = New Access.Application
    s = Application.CurrentProject.Path  "\"  "la_form.mdb"
    appAcc.OpenCurrentDatabase (s)
    appAcc.Visible = True
    apiShowWindow appAcc.hWndAccessApp, Me.grShow
End Sub

'  Окно базы данных
Private Sub butWinDataBase_Click()
    DoCmd.SelectObject acForm, "Пример 05", True
    If Me.butWinDataBase = False Then
        DoCmd.RunCommand acCmdWindowHide
    End If
    DoCmd.SelectObject acForm, "Пример 05", False
End Sub

' Выход из системы
Private Sub Form_Close()
    On Error Resume Next
    appAcc.Quit acQuitSaveNone
    Err.Clear
End Sub

07. Этот пример показывает как с использованием API интерфейса запустить таймер для выполнения некоторой программы. При описании программы используется функция AddressOf, возвращающая указатель на внешнюю программу.

Private hTimer As Long ' Указатель на запущенный процесс

Private Const TIME_ONESHOT = 0 ' Событие случается однажды
Private Const TIME_PERIODIC = 1 ' Событие случается через uDelay миллисекунд

' Запуск процесса
Private Declare Function apiTimeSetEvent Lib "winmm.dll" Alias "timeSetEvent" _
 (ByVal uDelay As Long, _
  ByVal uResolution As Long, _
  ByVal lpFunction As Long, _
  ByVal dwUser As Long, _
  ByVal uFlags As Long) As Long

' Уничтожение процесса
Private Declare Function apiTimeKillEvent Lib "winmm.dll" Alias "timeKillEvent" _
 (ByVal uID As Long) As Long


' Функция запуска событий
Private Sub butExec_Click()
Dim uDelay As Long
Dim uResolution As Long
Dim dwUser As Long
Dim fuEvent As Long

   uDelay = Me.uDelay * 1000 ' Число секунд
   uResolution = Me.uResolution
   dwUser = Me.dwUser
   uFlags = Me.uFlags ' uFlags = TIME_PERIODIC
   hTimer = apiTimeSetEvent(uDelay, _
                           uResolution, _
                           AddressOf funTimerProc, _
                           dwUser, _
                           uFlags)
End Sub


' Программа для выполнения процесса таймера
Public Function funTimerProc(ByVal uID As Long, _
                          ByVal uMsg As Long, _
                          ByVal dwUser As Long, _
                          ByVal dw1 As Long, _
                          ByVal dw2 As Long) As Long
Dim frm As Form
    Set frm = Forms("Example 07")
    frm.msg = "Время: "  Format(time, "hh:nn:ss")  _
        ", ID= "  uID  _
        ", Msg="  uMsg  _
        ", User="  dwUser  _
        ", dw1="  dw1  _
        ", dw2="  dw2  vbNewLine  frm.msg
    funTimerProc = 0
'    Debug.Print uID, uMsg, dwUser, dw1, dw2
End Function

04. Этот пример показывает как с использованием API интерфейса управлять буфером Windows. Используется класс и api интерфейс. Это более надежный способ, чем другие без api интерфейса.

' Функции управления буфером
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
    (ByVal uFormat As Integer) As Integer
Private Declare Function apiOpenClipboard Lib "user32" Alias "OpenClipboard" _
    (ByVal hWnd As Long) As Integer
Private Declare Function apiSetClipboardData Lib "user32" Alias "SetClipboardData" _
    (ByVal uFormat As Integer, _
     ByVal hData As Long) As Long
Private Declare Function apiGetClipboardData Lib "user32" Alias "GetClipboardData" _
    (ByVal uFormat As Integer) As Long
Private Declare Function apiCloseClipboard Lib "user32" Alias "CloseClipboard" _
    () As Integer
Private Declare Function apiEmptyClipboard Lib "user32" Alias "EmptyClipboard" _
    () As Integer

' Функции управления памятью
Private Declare Function apiGlobalAlloc Lib "kernel32" Alias "GlobalAlloc" _
    (ByVal uFlags As Integer, _
     ByVal dwBytes As Long) As Long
Private Declare Function apiGlobalSize Lib "kernel32" Alias "GlobalSize" _
    (ByVal hMem As Long) As Integer
Private Declare Function apiGlobalLock Lib "kernel32" Alias "GlobalLock" _
    (ByVal hMem As Long) As Long
Private Declare Sub apiMoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (ByVal strDest As Any, _
     ByVal lpSource As Any, _
     ByVal Length As Long)
Private Declare Function apiGlobalUnlock Lib "kernel32" Alias "GlobalUnlock" _
    (ByVal hMem As Long) As Integer
Private Declare Function apiGlobalFree Lib "kernel32" Alias "GlobalFree" _
    (ByVal hMem As Long) As Long

' api-Константы памяти
Private Const GMEM_FIXED = H0
Private Const GMEM_MOVEABLE = H2
Private Const GMEM_NOCOMPACT = H10
Private Const GMEM_NODISCARD = H20
Private Const GMEM_ZEROINIT = H40
Private Const GMEM_MODIFY = H80
Private Const GMEM_DISCARDABLE = H100
Private Const GMEM_NOT_BANKED = H1000
Private Const GMEM_SHARE = H2000
Private Const GMEM_DDESHARE = H2000
Private Const GMEM_NOTIFY = H4000
Private Const GMEM_LOWER = GMEM_NOT_BANKED
Private Const GMEM_VALID_FLAGS = H7F72
Private Const GMEM_INVALID_HANDLE = H8000
Private Const GMEM_TEXT = (GMEM_MOVEABLE Or GMEM_DDESHARE)

' api-Форматы буфера
Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_SYLK = 4
Private Const CF_DIF = 5
Private Const CF_TIFF = 6
Private Const CF_OEMTEXT = 7
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_RIFF = 11
Private Const CF_WAVE = 12
Private Const CF_UNICODETEXT = 13
Private Const CF_ENHMETAFILE = 14

'==============================================================
'  Копируем текст в буфер
'
Function CopyText(strText As String) As Variant
Dim hMem As Long
Dim lpMem As Long
Dim l As Long

    ' Выделение памяти
    l = Len(strText) + 1 ' Длина строки с учетом символа \0 (c++)
    hMem = apiGlobalAlloc(GMEM_TEXT, l) ' Память для буфера
    
    ' Управление памятью
    lpMem = apiGlobalLock(hMem) ' Блокируем часть памяти
    Call apiMoveMemory(lpMem, strText, l) ' Копируем строку в память
    Call apiGlobalUnlock(hMem) ' Разблокируем память
    
    ' Управление буфером
    Call apiOpenClipboard(0) ' Открываем буфер
    Call apiEmptyClipboard ' Очищаем буфер
    Call apiSetClipboardData(CF_TEXT, hMem) ' Загружаем текст
    Call apiCloseClipboard ' Закрываем буфер
    
    ' Освобождаем память
    Call apiGlobalFree(hMem)
End Function

'==============================================================
'  Получаем текст из буфера
'
Public Function GetText() As Variant
Dim hMem As Long
Dim lpMem As Long
Dim s As String
Dim l As Long

    ' Проверяем формат буфера
    If Not CBool(IsClipboardFormatAvailable(CF_TEXT)) Then
        Exit Function
    End If
   
    ' Работаем с буфером и памятью
    Call apiOpenClipboard(0) ' Открываем буфер
    hMem = apiGetClipboardData(CF_TEXT) ' Получаем заголовок данных в буфере
    l = apiGlobalSize(hMem) ' Определяем размер строки
    s = Space$(l) ' Выделение памяти для строки
    lpMem = apiGlobalLock(hMem) ' Блокируем память
    Call apiMoveMemory(s, lpMem, l) ' Копируем информацию из буфера в строку
    Call apiGlobalUnlock(hMem) ' Разблокирование памяти
    Call apiCloseClipboard ' Закрываем буфер
    
    ' Возвращаем результат
    GetText = Left$(s, InStr(1, s, Chr$(0)) - 1)
    
End Function

05. Данный пример показывает бинарный вид файла Access. Когда вы сможете читать файлы Access бинарным способом, то Вам не будут страшны программы взломщики. Например, Вы сохранили в базе данных свойства, которые используются для авторизации. Далее нашли в базе данных смещение и расчитали контрольную сумму этих байт. Используя для проверки авторизации это число, то можно понять как прошла авторизация. Если неправильно (взломщик переписал байты), то можно "аккуратно", не выключая программу, "подать к столу" "отравленные" данные (реверс строки, vbNewLine добавить в текст и т.п.).

'==============================================================
'   Загрузка файла
Public Function funLoadDataBase(strFile As String)
Dim dbs As DAO.Database, rst As DAO.Recordset
Dim j As Long
Dim strСмещение As String
Dim strИсходник As String
Dim strЦифровик As String
Dim ID As Byte, bt As Byte

    'Проверяем файл и читаем его
    If strFile  "" Then
        Me.Parent.Tag = "start"
        ' Удаляем все из таблицы
        Set dbs = CurrentDb
        dbs.Execute "DELETE * FROM [Пример 05]"
        Me.Requery
        On Error GoTo 999
            ID = FreeFile 'Получаем свободный идентификатор файла
            Set rst = dbs.OpenRecordset("SELECT * FROM [Пример 05]")
            Open strFile For Binary As ID 'Открываем файл
            j = 0
            Do While Not EOF(ID)    ' Проверка конца файла
                strСмещение = j 'или hex(j)
                strИсходник = ""
                strЦифровик = ""
                Me.Parent.myTimer.Caption = " Загрузка: "  Format(j, "000000")
                DoEvents
                Do While Not EOF(ID)    ' Проверка конца файла
                    j = j + 1
                    Get #ID, , bt 'Читаем байты
                    strЦифровик = strЦифровик  Format(CLng(bt), "000")  " "
                    If (bt  32) Or (bt  255) Then
                        strИсходник = strИсходник  "."
                    Else
                        strИсходник = strИсходник  Chr(bt)
                    End If
                    If (j \ 16) = (j / 16) Then Exit Do
                Loop
                ' Вставляем строку
                rst.AddNew
                rst!Смещение = strСмещение
                rst!Исходник = strИсходник
                rst!Цифровик = strЦифровик
                rst.Update
                If Me.Parent.Tag = "stop" Then Exit Do
            Loop
            rst.Close
            Me.Parent.myTimer.Caption = " Загрузка завершена"
            Me.Requery
            Close 'Закрываем открытые файлы
    End If
    Exit Function
999:
    MsgBox Err.Description
End Function

02. Метод защиты используйется в основном для модификации некоторых не очень важных строк базы данных, например, телефона. Применять для защиты паролей, даже если Вы добавите "мусор", такой метод нельзя. Главное это - то, что он работает быстро и требует использования специальных функций шифрования.

Private Sub Form_Current()
    Me.Parent.myPhone.Caption = "Правильный телефон: "  Format(StrReverse(Me.Телефон), "@@@-@@-@@")
End Sub

04. У каждого компьютера в организации могут быть различные диски, имеющий свой уникальный номер. Если прочитать эту информацию, то можно создать программу, которая будет привязана к конкретному компьютеру.

'  Получаем информацию о серийных номерах
'
Private Sub Form_Load()
Dim fs, dc, D, s As String
On Error Resume Next
    s = ""
    ' Получаем информацию о файловой системе
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set dc = fs.Drives
    For Each D In dc
        s = s  D.DriveLetter  ": серийный номер: "  D.SerialNumber  ";"
        Err.Clear
    Next D
    Me.myList.RowSource = s
End Sub