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

08. Пример 8 показывает защиту базы данных путем скрытия ее объектов: таблиц, запросов, полей

Private Sub butExecute_Click()
Dim dbs As DAO.Database, tdf As DAO.TableDef, fld As DAO.Field, prpLoop As DAO.Property
    ' Отображаем/гасим невидимые объекты базы данных
    Application.SetOption "Show Hidden Objects", CBool(Not Me.flagViewObject)
    
    ' DAO - метод
    Set dbs = CurrentDb
    Me.progress = ""
    For Each tdf In dbs.TableDefs
        If ((tdf.Attributes And dbSystemObject) = 0) Then
            ' Отображаем/гасим таблицы пользователя
            Me.progress = Me.progress  tdf.Name  ", Visible="  (Not CBool(Me.flagViewTable))  vbNewLine
            Application.SetHiddenAttribute acTable, tdf.Name, Me.flagViewTable
            ' Отображаем/гасим поля пользователя
            For Each fld In tdf.Fields
                fld.Properties("ColumnHidden") = CBool(Me.flagViewField)
            Next fld
        End If
    Next tdf
    
End Sub

Небольшой пример для использования файла справки в Access

' Вызов справки
Private Sub butHelp1_Click()
    Me.Refresh
    Const intHelpFile As Long = 1
    Const IdTopic As Long = 5

    Select Case Me.HelpID
    Case 1:  HtmlHelp hwnd, HFile(intHelpFile), HH_DISPLAY_TOC, 0
    Case 2:  HtmlHelp hwnd, HFile(intHelpFile), HH_DISPLAY_INDEX, 0
    Case 3:  HTMLHelpTopic hwnd, HFile(intHelpFile), HH_DISPLAY_TOPIC, Me.Topic
    Case 4:  HtmlHelp hwnd, HFile(intHelpFile), HH_HELP_CONTEXT, IdTopic
    Case 5:  ShowSearch (intHelpFile)
    End Select
End Sub

' Найти справочный файл
Public Function HFile(ByVal i_HFile As Integer) As String
  Select Case i_HFile
  Case 1:    HFile = Application.CodeProject.Path  "\help\Автоматизация.chm"
  Case 2:    HFile = Application.CodeProject.Path  "\help\Лекции Access.chm"
  End Select
  If Dir(HFile, vbNormal) = "" Then MsgBox "Файл не существует: "  HFile
End Function

'----- Отобразить вкладку поиска
'----- Ошибка: start searching with a string dosn't work
'
Public Sub ShowSearch(ByVal intHelpFile As Integer)
Dim searchIt As HH_FTS_QUERY
  With searchIt
    .cbStruct = Len(searchIt)
    .fUniCodeStrings = 1
    .pszSearchQuery = "Папка"
    .iProximity = 0
    .fStemmedSearch = 0
    .fTitleOnly = 1
    .fExecute = 1
    .pszWindow = ""
  End With
  Call HtmlHelpSearch(0, HFile(intHelpFile), HH_DISPLAY_SEARCH, searchIt)
End Sub

' http://www.help-info.de/en/Help_Info_HTMLHelp/hh_api.htm#VB6
Type HH_IDPAIR
  dwControlId As Long
  dwTopicId As Long
End Type

'This array should contain the number of controls that have
'context-sensitive help, plus one more for a zero-terminating
'pair.

Public ids(2) As HH_IDPAIR

Declare Function GetDlgCtrlID Lib "user32" _
  (ByVal hwnd As Long) As Long

Public Declare Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpA" _
               (ByVal hwndCaller As Long, ByVal pszFile As String, _
                ByVal uCommand As Long, ByVal dwData As Long) As Long
                
Public Declare Function HTMLHelpTopic Lib "hhctrl.ocx" Alias "HtmlHelpA" _
               (ByVal hwndCaller As Long, ByVal pszFile As String, _
                ByVal uCommand As Long, ByVal dwData As String) As Long
         
Public Declare Function HtmlHelpSearch Lib "hhctrl.ocx" Alias "HtmlHelpA" _
               (ByVal hwndCaller As Long, ByVal pszFile As String, _
                ByVal uCommand As Long, dwData As HH_FTS_QUERY) As Long
         

Public Const HH_DISPLAY_TOPIC = H0         ' select last opened tab, [display a specified topic]
Public Const HH_DISPLAY_TOC = H1           ' select contents tab, [display a specified topic]
Public Const HH_DISPLAY_INDEX = H2         ' select index tab and searches for a keyword
Public Const HH_DISPLAY_SEARCH = H3        ' select search tab and perform a search
      
Private Const HH_SET_WIN_TYPE = H4
Private Const HH_GET_WIN_TYPE = H5
Private Const HH_GET_WIN_HANDLE = H6
Private Const HH_DISPLAY_TEXT_POPUP = HE   ' Display string resource ID or
  
Public Const HH_HELP_CONTEXT = HF          ' display mapped numeric value in dwData
     
Private Const HH_TP_HELP_CONTEXTMENU = H10 ' Text pop-up help, similar to WinHelp's HELP_CONTEXTMENU.
Private Const HH_TP_HELP_WM_HELP = H11     ' text pop-up help, similar to WinHelp's HELP_WM_HELP.


Public Type HH_FTS_QUERY                ' UDT for accessing the Search tab
  cbStruct          As Long             ' Sizeof structure in bytes.
  fUniCodeStrings   As Long             ' TRUE if all strings are unicode.
  pszSearchQuery    As String           ' String containing the search query.
  iProximity        As Long             ' Word proximity.
  fStemmedSearch    As Long             ' TRUE for StemmedSearch only.
  fTitleOnly        As Long             ' TRUE for Title search only.
  fExecute          As Long             ' TRUE to initiate the search.
  pszWindow         As String           ' Window to display in
End Type

06. Простейший вариант для определения какой файл используется: mde или mdb смотрите пример 6

Private Sub Form_Load()
Dim Flag As Variant, dbs As Database
On Error GoTo 999
    ' Получаем информацию о текущей базе
    Set dbs = CurrentDb
    If dbs.Properties("MDE") = "T" Then ' Такого свойства нет в mdb
        Me.myTypeDB = 2 ' Указываем вид для формы
    End If
    Exit Sub
999:
    Err.Clear
    Me.myTypeDB = 1
End Sub

14. Команда DoCmd.SendObject посылает факс из Access, если указать ключевое слово fax в параметрах

Private Sub butPrint_Click()
    On Error Resume Next
    DoCmd.SendObject acReport, "Пример 14", acFormatRTF, _
                 "[fax: "  Me.Fax  "]", , , , , False
    Err.Clear
End Sub

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

'==============================================================
' Включить фильтр
Private Sub allFirms_AfterUpdate()
Dim rpt As Report
    Set rpt = Reports("Пример 15")
    rpt.Filter = "Описание='"  Me.allFirms  "'"
    rpt.FilterOn = True
End Sub

'==============================================================
' Удалить фильтр
Private Sub butDelete_Click()
    Reports("Пример 15").FilterOn = False
End Sub

'==============================================================
' Закрытие отчета
Private Sub Form_Close()
    DoCmd.Close acReport, "Пример 15"
End Sub

'==============================================================
' Открыть отчет
Private Sub Form_Open(Cancel As Integer)
    DoCmd.OpenReport "Пример 15", acViewPreview
End Sub

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

Dim MaskPasJet4(40) As Byte  ' Маска пароля (Длина 40 байт, из эксперимента)
Dim MaskInfJet4(3) As Byte  ' Дополнительная информация по паролю

'=============================================================
' Анализ пароля
'   Метод заключается в том, что мы создаем файл без пароля,
'   и несколько файлов с паролями. Далее сравниваем по байтам
'   зашифрованный и незашифрованный  файлы и результат записы-
'   ваем в таблицу [Пример 07]
'   Таким образом, мы определяем
'   - длину пароля;
'   - смещение пароля от начала файла;
'   - позиции меняющихся байтов.
'
Public Function funAnalysisPassword(strMdb As String, pswDiff As String, pswBytes As String, pswMask) As String
Dim ID1 As Byte, ID2 As Byte, bt1 As Byte, bt2 As Byte
Dim i As Long, j As Long, mdb As String
Dim pswLen As Long
    ' Открываем файл без пароля
    ID1 = FreeFile ' Получаем свободный идентификатор файла
    mdb = Application.CurrentProject.Path  "\PasswordNo.mdb"
    funCreateDatabase mdb, ""  ' Создаем базу данных без пароля
    Open mdb For Binary As ID1 ' Открываем файл
    
    ID2 = FreeFile 'Получаем свободный идентификатор файла
    Open strMdb For Binary As ID2 'Открываем файл
    
    ' Исследуем 2048 байт заголовка
    pswDiff = ""
    For j = 1 To 2048
        Get #ID1, j, bt1 'Читаем байты незашифрованного файла
        Get #ID2, j, bt2 'Читаем байты зашифрованного файла
        If (bt1  bt2) Then
            ' Сравниваем байты для определения различий файлов
            pswDiff = pswDiff  Format(j, "000")  ".("  Format(bt1, "000")  "-"  Format(bt2, "000")  ") "
        End If
    Next
    
    ' Исследуем пароль
    pswMask = "" ' Маска пароля
    pswBytes = "" ' Байты пароля
    pswPos = 67 ' Позиция пароля (из экспериментов)
    pswLen = 20 * 2 ' Длина пароля (из экспериментов)
    For j = 0 To pswLen - 1
         Get #ID1, pswPos + j, bt1 ' Читаем маску пароля
         Get #ID2, pswPos + j, bt2 ' Читаем байты пароля
         pswMask = pswMask  Format(bt1, "000 ")  ' Форматируем маску
         pswBytes = pswBytes  Format(bt2, "000 ") ' Форматируем пароль
    Next j
    Close ' Закрываем открытые файлы
    
    ' Удаляем временные файлы
    If Dir(mdb)  "" Then Kill mdb
End Function

'=============================================================
'   Получаем маску пароля, путем чтения ее из не защищенной
'   базы данных. Всего 40 байт + 3 информационных
'
'       [67 - 69]   055 056 212 156 250 163 206
'       040 230 118 038 138 096 049 004 123 054
'       144 226 223 177 018 100 019 067 170 063
'       177 051 081 241 121 091 247 037 124 042
'       ...
'       [115-117]
'
'   Примечание. Маска пароля начинается с 67 байта. Байты [67-69]
'      меняются в зависимости от даты, установленной на компьютере.
'      Например, на 17.03.2001 = 228,107,236. Байты [115-117] меняются
'      при каждом создании базы данных. Для расшифровки пароля
'      достаточно иметь 40 байт.
'
Public Function funGetMaskPassword(dateFile As Variant)
Dim mdb As String, curDate
    
    curDate = Date ' Сохраняем текущую дату
    Date = Format(dateFile, "dd.mm.yyyy") ' Устанавливаем дату файла
    mdb = Application.CurrentProject.Path  "\PasswordNo.mdb"
    funCreateDatabase mdb, ""  ' Создаем базу данных без пароля
    Date = curDate ' Устанавливаем текущую дату
    
    ID = FreeFile ' Получаем свободный идентификатор файла
    Open mdb For Binary As ID ' Открываем файл в двоичном виде
    For i = 0 To UBound(MaskPasJet4) - 1
        Get #ID, 67 + i, MaskPasJet4(i) ' Читаем маску
    Next i
    For i = 0 To UBound(MaskInfJet4) - 1
        Get #ID, 115 + i, MaskInfJet4(i) ' Читаем информацию
    Next i
    Close #ID
    
    ' Удаляем временные файлы
    If Dir(mdb)  "" Then Kill mdb
End Function

'=============================================================
'   Чтение пароля из базы данных Microsoft Access 2000
'      Из экспериментов выяснено, что длина пароля для Access равна
'   40 байт, смещение от начала файла 67 байт. Алгоритм зашифровки
'   XOR, символы хранятся в формате UNICODE, т.е 2 байта на символ.
'      Для применения алгоритма расшифровки надо определить маску
'   пароля. Маска не постоянная. В ней надо найти 3 байта, которые
'   связаны с датой создания базы. Проверено, что 67 байт - меняется
'   ежедневно, 68 байт - ежегодно, а 69 байт - еще более длительный
'   период.
'      Для получения маски передадим в функцию funGetMaskPassword
'   дату создания файла базы данных (Наиболее точно - надо найти
'   в базе дату создания файла).
'
Public Function funReadPassword(strMdb As String) As String
Dim ID As Byte
Dim j As Long
Dim ss As String
Dim pBytes(40) As Byte
Dim paswYes As Boolean
    
    ' Получаем байты маски пароля
    funGetMaskPassword FileDateTime(strMdb)
    
    ' Читаем байты пароля
    ID = FreeFile 'Получаем свободный идентификатор файла
    Open strMdb For Binary As ID 'Открываем файл
    For j = 0 To 40 - 1 ' Длина пароля (из экспериментов)
         Get #ID, 67 + j, pBytes(j) ' Читаем байты пароля
    Next j
    Close ' Закрываем открытые файлы
    
    ' Выбираем для расшифровки простейший алгоритм XOR
    ss = ""
    For j = 0 To 40 - 1 ' Длина пароля (из экспериментов)
        ss = ss  Chr(pBytes(j) Xor MaskPasJet4(j))
    Next j
    
    ' Вычисляем пароль
    ss = StrConv(ss, vbFromUnicode)  vbNullChar      ' Конвертируем пароль в строку
    j = InStr(1, ss, vbNullChar, vbBinaryCompare) - 1 ' Длина пароля
    
    ' Проверка наличия/отсутствия пароля (алгоритм из опыта)
    funReadPassword = ""
    If InStr(j + 1, ss, Left(ss, 2), vbBinaryCompare) Then
        MsgBox "Нет пароля!", vbExclamation, "Лидер Access"
    Else
        ss = Left(ss, j)
        ' Тест для пароля
        If funTestPassword(strMdb, ss) = True Then
            funReadPassword = ss
            MsgBox "Ваш пароль: "  ss, vbExclamation, "Лидер Access"
        Else
            ' Можно найти перебором первый байт пароля
            MsgBox "Пароль определить не удалось! "  ss, vbExclamation
        End If
    End If
    
End Function


'=============================================================
'  Пример теста на определение пароля
'
Public Function funTestPassword(strMdb As String, strPassword As String) As Boolean
On Error Resume Next
Dim cnn As New ADODB.Connection
    cnn.ConnectionString = _
        "Provider=Microsoft.Jet.OLEDB.4.0"  _
        ";Data Source="  strMdb  _
        ";Mode=Read;"  _
        ";Jet OLEDB:Database Password="  strPassword
    cnn.Open
    ' Проверка открытия
    If Err.Number Then
       funTestPassword = False
       Err.Clear
    Else
       funTestPassword = True
       cnn.Close
    End If
    Set cnn = Nothing
End Function
'=============================================================
'  Пример создания базы данных с паролем
'  DAO
'    DBEngine.CreateDatabase strMdb, dbLangCyrillic
'    DBEngine.CreateDatabase strMdb, dbLangCyrillic  ";pwd="  strPassword
'  и ADOX ...
'
Public Function funCreateDatabase(strMdb As String, strPassword) As Boolean
Dim cat As New ADOX.Catalog
    On Error GoTo 999  'Назначаем переход по ошибке
    funCreateDatabase = False 'Возвращаем результат при ошибке
    If Dir(strMdb)  "" Then Kill strMdb 'Уничтожаем старую базу данных
    If strPassword = "" Then
        cat.Create "Provider=Microsoft.Jet.OLEDB.4.0"  _
                   ";Data Source="  strMdb
    Else
        cat.Create "Provider=Microsoft.Jet.OLEDB.4.0"  _
                   ";Data Source="  strMdb  _
                   ";Jet OLEDB:Database Password="  strPassword
    End If
    Set cat = Nothing
    funCreateDatabase = True 'Возвращаем результат
    Exit Function 'Выходим из программы
999:
    MsgBox "Создание пароля: "  Err.Description 'Сообщаем об ошибке
    Err.Clear 'Очищаем поток от ошибок
End Function

'==============================================================
' Данные примеры созданы для дополнительной информации по ши��рованию
' Они носят чисто экспериментальный характер, и их нельзя применять
' на реальных базах данных, т.к. базы данных потом нельзя будет
' открыть.

'==============================================================
'   Пример помогает удалить пароль из файла
'   (betta версия)
'
Public Sub funDeletePassword(strMdb As String)
Dim i As Integer, ID As Byte
    On Error GoTo 999
    If MsgBox("Удалить пароль файла ?", vbOKCancel + vbExclamation, "Изменение пароля") = vbOK Then
        ' Получаем байты маски пароля
        funGetMaskPassword FileDateTime(strMdb)
        ID = FreeFile ' Получаем свободный идентификатор файла
        Open strMdb For Binary As ID ' Открываем файл в двоичном виде
        For i = 0 To UBound(MaskPasJet4) - 1
            Put #ID, 67 + i, MaskPasJet4(i)
        Next i
        ' Сохраняем информационные байты
        For i = 0 To UBound(MaskInfJet4) - 1
            Put #ID, 115 + i, MaskInfJet4(i)
        Next i
        Close #ID 'Закрываем открытый файл
        MsgBox "Пароль удален!", vbInformation, "Лидер Access" ' Сообщение
    End If
    
    Exit Sub
999:
    MsgBox Err.Description
End Sub

'==============================================================
'   Пример помогает записать пароль в файл
'   (betta версия)
'
Public Sub funWritePassword(strMdb As String, strPassword As String)
    On Error GoTo 999
    If MsgBox("Записать пароль: "  strPassword  "?", vbOKCancel + vbExclamation, "Изменение пароля") = vbOK Then
        ' Получаем байты маски пароля
        funGetMaskPassword FileDateTime(strMdb)
    
        Dim i As Integer, ID As Byte
        ID = FreeFile 'Получаем свободный идентификатор файла
        Open strMdb For Binary As ID 'Открываем файл в двоичном виде
        
        ' Очищаем пароль
        For i = 0 To UBound(MaskPasJet4) - 1
            Put #ID, 67 + i, MaskPasJet4(i)
        Next i
        
        ' Сохраняем пароль
        Dim ss As String, j As Long
        ss = StrConv(strPassword, vbUnicode) ' Конвертируем пароль в Unicode
        For i = 0 To Len(ss) - 1
            ' Шифруем байты и записываем в файл
            j = Asc(Mid(ss, i + 1, 1))
            Put #ID, 67 + i, MaskPasJet4(i) Xor CByte(j)
        Next i
        ' Сохраняем информационные байты
        'Put #ID, 115, CByte(???)
        'Put #ID, 116, CByte(???)
        'Put #ID, 117, CByte(???)
        Close 'Закрываем открытый файл
        MsgBox "Пароль установлен!", vbInformation, "Лидер Access" ' Сообщение
    End If
    
    Exit Sub
999:
    MsgBox Err.Description
End Sub

02. Это делается в конструкторе отчетов, поэтому для понимания этого примера откройте mdb файл

05. Пример показывает использование файла "PRN" из Microsoft Access. Под ним в операционной системе хранится принтер, присоединенный к текущему компьютеру. Эти примеры выгружают данные на принтер, шрифт и т.п. используя разные варианты

Private Sub Report_Open(Cancel As Integer)
Dim ID As Byte
    On Error GoTo 999
    If MsgBox("Распечатать данные ?"  Chr(13)  "/Команды печати закоментированы/", _
              vbOKCancel + vbExclamation, "Печать") = vbOK Then
        MsgBox ("1. Проверка подчеркивания")
        '1. Проверка режима подчеркивания у принтера
        '   При вводе русских символов их надо вести в ДОСовской кодировке
        'ID = FreeFile
        'Open "c:\Epson_test.txt" For Output As #ID
        'Open "c:\Epson_test.txt" For Binary Access Write As #ID
        'Write #ID, Chr(27)  "-"  Chr(1)  "Test-underline"  Chr(27)  "-"  Chr(0)
        'Close #ID
'        FileCopy "Epson_test.txt", "PRN"
        
        MsgBox ("2. Загрузка шрифта")
        '2. Загрузка DOS - драйвера. Возьмите у поставщика или из Интернета
        'FileCopy "c:\Epson_Font_Driver", "PRN"
        
        MsgBox ("3. Печать отчета")
        '3. Настройте принтер на DRAFT-режим через кнопки управления и далее
        '   отпечатайте отчет в ДОСовской кодировке
        'DoCmd.OutputTo acOutputReport, "Пример 5", acFormatTXT, "PRN"
    End If
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

02. Когда пользователь работает с формой, то может возникнуть ситуация, что он не ввел в нее некоторые данные (Страна, Фамилия и т.п.). Этот алгоритм решает такую проблему, пока не будут введены данные в ключевые поля форма не закроется.

' Проверка при выгрузке окна
Private Sub Form_Unload(Cancel As Integer)
    If Nz(Me.Country, "") = "" Then
        Me.Country.Controls(0).ForeColor = RGB(255, 0, 0)
        MsgBox "НЕ заполнено поле Страна!", vbCritical, "Ошибка при вводе данных"
        Cancel = True ' Отменяем закрытие окна
        DoCmd.CancelEvent ' Отменяем последнее событие
        Exit Sub
    End If
    If Nz(Me.City, "") = "" Then
        Me.City.Controls(0).ForeColor = RGB(255, 0, 0)
        MsgBox "НЕ заполнено поле Город!", vbCritical, "Ошибка при вводе данных"
        Cancel = True ' Отменяем закрытие окна
        DoCmd.CancelEvent ' Отменяем последнее событие
        Exit Sub
    End If
    ' Запрашиваем закрытие окна
    If MsgBox("Закрыть окно !", vbInformation + vbOKCancel, "Выход из программы")  vbOK Then
        Cancel = True
        DoCmd.CancelEvent
    End If
End Sub

10. Применяя функции в запросах SQL, можно добиться нужного формата полей в таблицах.

SELECT [Пример 10].Артикул AS Текст, CLng([Артикул]) AS Число1, CDbl([Артикул]) AS Число2 FROM [Пример 10];