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