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