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