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

 Microsoft Office: 2000,2002,2003,2007,2010  Архив с файлами: Перейти
 Операционная система: Windows XP,Vista  Применение: Базы данных Access
 Продажа: Купить  Файл исходника: ..\Access\03 Защита\la_protection1.mdb
 Язык интерфейса: Русский

   

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 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 StringAs String
Dim ID As Byte
Dim 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 StringAs 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 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 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

Copyright © 2002-2015 ООО Лидер Эксэсс
Сайт работает под управлением: ASP.NET, Access