modaccessfinality.bas

关于access数据库解密的源码

Attribute VB_Name = "modAccessFinality"
Option Explicit

#Const USE_DAO = 1
#If USE_DAO Then
  Public gDAO       As DAO.Database
#Else
  Public gADO       As ADODB.Connection
#End If
Public gbExit As Boolean
Public glCounts As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Function INNER_GetFileName(ByVal fbOpen As Boolean, _
                                  Optional ByVal fsFilter As String, _
                                  Optional ByVal fsDefaultExt As String, _
                                  Optional ByVal fsDefFile As String, _
                                  Optional ByVal fsDialogTitle As String) As String

   On Error GoTo ErrLabel
    Dim iReplace As Integer
    With frmMain.CommonDialog1
        If fsFilter = "" Then
          .Filter = "所有文件 (*.*)|*.*"
        Else
          .Filter = fsFilter
        End If
        .Flags = cdlOFNHideReadOnly Or cdlOFNExplorer
        .CancelError = True
        .DefaultExt = fsDefaultExt
        If fsDialogTitle <> "" Then .DialogTitle = fsDialogTitle
        If fsDefFile <> "" Then .FileName = fsDefFile
        Do
          If fbOpen Then
            .ShowOpen
          Else
            .ShowSave
          End If
          If Len(.FileName) = 0 Then
            Exit Function
          End If
          If Not fbOpen Then
            If Len(Dir(.FileName)) > 0 Then
               iReplace = MsgBox("代替存在的 " + .FileName + " 吗?", vbYesNoCancel + vbQuestion)
            Else
               iReplace = 0
            End If
            If iReplace = vbCancel Then
              Exit Function
            End If
          Else
            If Not (Len(Dir(.FileName)) > 0) Then Exit Function
          End If
        Loop While iReplace = vbNo  '不覆盖
        If Not fbOpen Then
         If iReplace = vbYes Then
            Kill .FileName
         End If
        End If
        INNER_GetFileName = .FileName
    End With
ErrLabel:
  Select Case Err.Number
    Case 75
      MsgBox Err.Description & ",请重新选择文件路径!", vbExclamation
  End Select
End Function

'fsRetVer为返回的数据库版本，可用于创建连接
'fbDirect=True,直接给出密码，不使用暴力破解
Public Function INNER_GetAccessPwd(fsDBsee As String, _
                                   fsRetVer As String, _
                                   Optional fbDirect As Boolean = True) As String
    Dim bytVer(2)      As Byte
    Dim bytDB_ID       As Byte
    Dim bytFile(39)    As Byte
    Dim bytDateKey(127) As Byte
    Dim l              As Long
    Dim n              As Long
    Dim iFreeFile      As Integer
    Dim sFileFlag      As String * 15
    
    Dim sKey2K         As String
    Dim sKey97         As String
    Dim bytKey()       As Byte
    Dim bytRslt()      As Byte
    Dim lAscii         As Long
    Dim lTemp          As Long
    Dim sPassword      As String
    
    On Error GoTo ErrLabel
    
    iFreeFile = FreeFile
    Open fsDBsee For Binary As #iFreeFile
    
    l = LOF(iFreeFile)
    
    If l > &H140 Then
      Get #iFreeFile, &H43, bytFile
      Get #iFreeFile, &H9D, bytVer
      Get #iFreeFile, &H15, bytDB_ID
      Get #iFreeFile, &H19, bytDateKey
      Get #iFreeFile, &H5, sFileFlag
    End If
    Close #iFreeFile
    
    If sFileFlag <> "Standard Jet DB" Then
      sPassword = "非ACCESS数据库文件"
      '实际上，文件开始的0x0001标志也可以做为判断依据
      GoTo Endlabel
    End If
    
    sKey2K = "3074EC37EBCB9CFA70D128E6A5398A60E21B7B3643FDDFB1C17B13437920B13382EE795B243A7C2A"
    sKey97 = "86FBEC375D449CFAC65E28E613"
    
    If bytVer(0) = 0 Then
      fsRetVer = "3.51"
    Else
      'Microsoft 似乎想在今后的版本中用该数据表示建立ADO的连接
      fsRetVer = Chr(bytVer(0)) & Chr(bytVer(1)) & Chr(bytVer(2))
    End If
    
    fsRetVer = IIf(bytDB_ID = 0, "ACCESS_97;", "ACCESS_2K;") & fsRetVer
    
    If (bytDB_ID = 1) And fbDirect Then
      sPassword = INNER_GetPwdDirect(bytDateKey)
      GoTo Endlabel
    End If
    
    If bytDB_ID = 1 Then
      '以下为解密过程
      If INNER_CanOpenDateBase(fsDBsee, "") Then '先假定数据库无密码
        GoTo Endlabel
      End If
      
      bytKey = INNER_Hex2ByteA(sKey2K)
      ReDim bytRslt(UBound(bytKey))
      For l = 0 To UBound(bytKey)
        bytRslt(l) = bytKey(l) Xor bytFile(l)
      Next l
      
      For n = 0 To glCounts
        If gbExit Then
          Exit Function
        End If
        sPassword = ""
        
        '这里，n值与本数据库创建的时间是相关的，n值一旦确定，密码便迎刃而解了。
        '由于此处演示暴力破解，因此n值的解法从略
        
        frmMain.Shape1.Width = frmMain.lblProcess.Width * (n + 1) / glCounts
'        bytTemp = 0
        For l = 0 To UBound(bytKey) \ 2
          If l Mod 2 = 0 Then
            If glCounts = 255 Then
              lAscii = bytRslt(2 * l) Xor n
            Else
              lAscii = (CLng(bytRslt(2 * l + 1)) * 256 + bytRslt(2 * l)) Xor n
            End If
            lTemp = lTemp Xor lAscii
          Else
            lAscii = CLng(bytRslt(2 * l + 1)) * 256 + bytRslt(2 * l)
          End If
          If lAscii <> 0 Then
            '在2000的数据库中，一个双字节的密码只占用一个位置。
            '这就是当前市面上大部分解密软件无法解密中文密码的关键。
            '因此，一个2000数据库，可以最长使用20个中文字来组成密码。
            'VB中恰好有ChrW来代替API  WideCharToMultiByte 对Unicode字节进行转换
            sPassword = sPassword & ChrW(lAscii)
          End If
        Next l
        If sPassword <> "" Then
          If INNER_CanOpenDateBase(fsDBsee, sPassword) Then
            GoTo Endlabel
          End If
        End If
      Next n
      If glCounts = 255 Then
        sPassword = "未找到密码，请尝试更多的密码！"
      End If
    ElseIf bytDB_ID = 0 Then
      bytKey = INNER_Hex2ByteA(sKey97)
      For l = 0 To UBound(bytKey)
        lAscii = bytKey(l) Xor bytFile(l)
        If lAscii <> 0 Then
          sPassword = sPassword & Chr(lAscii)
        End If
      Next l
    Else
      sPassword = "非ACCESS数据库文件"
    End If
    
    If sPassword = "" Then sPassword = "无密码"
    
Endlabel:
    INNER_GetAccessPwd = sPassword
    Exit Function
ErrLabel:
    INNER_GetAccessPwd = Err.Description
End Function

Public Function INNER_GetPwdDirect(fbytFile() As Byte) As String
    Dim l As Long
    Dim bytEncriptKey(3) As Byte '初始密码
    Dim bytEncriptRet(257) As Byte
    Dim dbl As Double
    Dim lKey As Long
    Dim lRslt(19)    As Long
    Dim sPassword As String
    
    bytEncriptKey(0) = &HC7
    bytEncriptKey(1) = &HDA
    bytEncriptKey(2) = &H39
    bytEncriptKey(3) = &H6B
    
    '先直接使用上面的初始密码通过查表的方法形成新的密钥
    '本函数有点DES算法的味道
    Call LoGetEncryptStr(bytEncriptKey, bytEncriptRet, 4)
    '利用上面形成的密钥对文件中的加密字串fbytFile进行解密，得到结果bytEncriptRet
    Call LoGetKey(bytEncriptRet, fbytFile, &H80)
    '比尔的原版ACCESS算法中，使用了数学协处理器的浮点指令FISTP、FSTCW等，
    '但我发现，采用CopyMemory方法有种殊途同归的感觉
    CopyMemory ByVal VarPtr(dbl), ByVal VarPtr(fbytFile(0)) + 90, 8
    'lKey是整个过程的关键，如果不是跟踪到核心算法，我是永远猜不透这个数值的来历的。
    '这就是我先前使用暴力的原因。
    lKey = Int(dbl)
    For l = 0 To 19
      lRslt(l) = fbytFile(l * 2 + 42) + 256 * CLng(fbytFile(l * 2 + 43))
      If l Mod 2 = 0 Then
        lRslt(l) = lRslt(l) Xor lKey
      End If
      If lRslt(l) <> 0 Then
        '用ChrW来代替WideCharToMultiByte对Unicode字节进行转换
        sPassword = sPassword & ChrW(lRslt(l))
      End If
    Next l
    INNER_GetPwdDirect = sPassword
End Function

Public Function INNER_CanOpenDateBase(fsFilename As String, fsPasswd As String) As Boolean
  On Error GoTo ErrLabel
  Dim sConn As String
  '通过暴力来测试连接是否正确的方式很多，这里，可以根据情况确定使用ADO或DAO来测试
  '实际上，也可以使用对Microsoft Access 10.0 Object Library的引用来进行测试。
  '这里，大家也可以学习到如何建立ADO或DAO的连接字串
  #If USE_DAO Then
    Set gDAO = DAO.OpenDatabase(fsFilename, False, 0, ";pwd=" & fsPasswd)
    INNER_CanOpenDateBase = True
    Set gDAO = Nothing
  #Else
    Set gADO = New ADODB.Connection
    sConn = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & fsFilename & _
            ";Jet OLEDB:Database Password =" & fsPasswd & ";"
    gADO.Open sConn
    INNER_CanOpenDateBase = True
    Set gADO = Nothing
  #End If
ErrLabel:
  DoEvents
End Function

'实用函数，将16进制的字符串转换成字节型的数组
Public Function INNER_Hex2ByteA(fsData As String) As Byte()
    Dim i As Integer
    Dim btyTemp() As Byte
    
    If fsData = "" Then fsData = 0
    If Len(fsData) < 2 Then
      ReDim btyTemp(0)
      btyTemp(0) = CByte("&H" & fsData)
    Else
      ReDim btyTemp(0 To Len(fsData) \ 2 - 1)
      For i = 0 To Len(fsData) \ 2 - 1
          btyTemp(i) = CByte("&H" & Mid(fsData, (i + 1) * 2 - 1, 2))
      Next i
    End If
    INNER_Hex2ByteA = btyTemp
End Function

'本函数将得到解密用的KEY
Private Function LoGetEncryptStr(fbytEncriptKey() As Byte, fbytEncriptRet() As Byte, flModeValue As Long)
  Dim l As Long
  Dim lTemp1 As Long
  Dim lTemp2 As Long
  Dim lTemp3 As Long
  Dim lTemp4 As Long
  Dim lTemp5 As Long
  
  For l = 0 To 255
    fbytEncriptRet(l) = l
  Next l
  lTemp1 = 0
  For l = 0 To 255
     lTemp1 = lTemp2
     lTemp1 = fbytEncriptKey(lTemp1)
     lTemp4 = fbytEncriptRet(l)
     lTemp1 = lTemp1 + lTemp4
     lTemp4 = lTemp3
     lTemp1 = lTemp1 + lTemp4
     lTemp1 = lTemp1 And &H800000FF
     lTemp3 = lTemp1
     lTemp1 = fbytEncriptRet(l)
     lTemp5 = lTemp1
     lTemp1 = lTemp3
     lTemp1 = fbytEncriptRet(lTemp1)
     fbytEncriptRet(l) = lTemp1
     lTemp4 = lTemp3
     fbytEncriptRet(lTemp4) = lTemp5
     lTemp1 = lTemp2
     lTemp1 = lTemp1 + 1
     lTemp4 = lTemp1 Mod flModeValue
     lTemp2 = lTemp4
  Next l
End Function

Private Function LoGetKey(fbytEncriptKey() As Byte, fbytKeyRet() As Byte, flMaxValue As Long)
   Dim l As Long
   Dim lTemp1 As Long
   Dim lTemp2 As Long
   Dim lTemp3 As Long
   Dim lTemp4 As Long
   Dim lTemp5 As Long
   Dim lTemp6 As Long
   Dim lTemp7 As Long
   Dim lTemp8 As Long
  
  lTemp4 = fbytEncriptKey(&H100)
  lTemp1 = fbytEncriptKey(&H101)
   
  For l = 1 To flMaxValue
    lTemp4 = lTemp4 + 1
    lTemp4 = lTemp4 And &H800000FF
    lTemp3 = lTemp4 And &HFF
    lTemp5 = fbytEncriptKey(lTemp3)
    lTemp1 = lTemp1 And &HFF
    lTemp5 = lTemp5 + lTemp1
    lTemp1 = lTemp5 And &H800000FF
    lTemp6 = fbytEncriptKey(lTemp4)
    lTemp5 = fbytEncriptKey(lTemp1)
    fbytEncriptKey(lTemp3) = lTemp5
    lTemp2 = lTemp1
    fbytEncriptKey(lTemp2) = lTemp6
    lTemp5 = fbytEncriptKey(lTemp3)
    lTemp3 = fbytEncriptKey(lTemp1 And &HFF)
    lTemp5 = lTemp5 + lTemp3
    lTemp5 = lTemp5 And &H800000FF
    lTemp7 = lTemp5
    lTemp3 = lTemp8
    lTemp5 = fbytEncriptKey(lTemp5)
    fbytKeyRet(lTemp3) = fbytKeyRet(lTemp3) Xor lTemp5
    lTemp8 = lTemp8 + 1
  Next l
  fbytEncriptKey(&H100) = lTemp4
  fbytEncriptKey(&H101) = lTemp1
End Function