modaccessfinality.bas

Access密码破解终结3.01 超级版(VB)

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 fsFilter As String = "All (*.*)| *.*", _
                                  Optional ByVal fsDefaultExt As String, _
                                  Optional ByVal fsDefFile As String, _
                                  Optional ByVal fsDialogTitle As String, _
                                  Optional ByVal flHwnd As Long = -1) As String

   Dim CommonDialog1 As New clsCommonDialog
   If fbOpen Then
      If (CommonDialog1.VBGetOpenFileName(Filename:=fsDefFile, _
                                          Filter:=fsFilter, _
                                          FileTitle:=fsDialogTitle, _
                                          DefaultExt:=fsDefaultExt, _
                                          Owner:=flHwnd)) Then
         INNER_GetFileName = fsDefFile
      End If
   Else
      If (CommonDialog1.VBGetSaveFileName(Filename:=fsDefFile, _
                                          Filter:=fsFilter, _
                                          FileTitle:=fsDialogTitle, _
                                          DefaultExt:=fsDefaultExt, _
                                          Owner:=flHwnd)) Then
         INNER_GetFileName = fsDefFile
      End If
   End If
   INNER_GetFileName = INNER_GetStrFromBuffer(INNER_GetFileName)
   Set CommonDialog1 = Nothing
End Function

Public Function INNER_FileExists(fsFileName As String) As Boolean
  On Error GoTo ErrLabel
  If fsFileName = "" Then Exit Function
  If Right(fsFileName, 1) = "\" Then Exit Function
  If Len(Dir(fsFileName)) > 0 Then
    If UCase(INNER_FileName(fsFileName)) = UCase(Dir(fsFileName)) Then
      INNER_FileExists = True
    End If
  End If
ErrLabel:
End Function

Public Function INNER_FileName(sFileName As String) As String
  Dim nIdx As Integer
  For nIdx = Len(sFileName) To 1 Step -1
      If Mid$(sFileName, nIdx, 1) = "\" Then
          INNER_FileName = Mid$(sFileName, nIdx + 1)
          Exit Function
      End If
  Next nIdx
  INNER_FileName = sFileName
End Function

Public Function INNER_GetStrFromBuffer(sz As String) As String
  If InStr(sz, vbNullChar) Then
    INNER_GetStrFromBuffer = Left$(sz, InStr(sz, vbNullChar) - 1)
  Else
    INNER_GetStrFromBuffer = sz
  End If
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)
      If sPassword = "" Then sPassword = "无密码"
      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