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

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