module1.bas

获取access密码

Attribute VB_Name = "Module1"
Option Explicit

#Const USE_DAO = 0
#If USE_DAO Then
  Public gDAO       As DAO.Database
#Else
  Public gADO       As ADODB.Connection
#End If

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

Public Function INNER_GetAccessPwd(fsDBsee As String, fsRetVer As String) As String
    Dim sTemp          As String
    Dim bytVer(2)      As Byte
    Dim bytDB_ID       As Byte
    Dim byt2           As Byte
    Dim bytSecret(19)  As Byte
    Dim bytEncrept(19) As Byte
    Dim l              As Long
    Dim n              As Long
    Dim lMax           As Long
    Dim iFreeFile      As Integer
    
    iFreeFile = FreeFile
    Open fsDBsee For Binary As #iFreeFile
    
    Get #iFreeFile, &H9D, bytVer
    If bytVer(0) = 0 Then
      fsRetVer = "3.51"
    Else
      'Microsoft 似乎想在今后的版本中用该数据表示建立ADO的连接
      fsRetVer = Chr(bytVer(0)) & Chr(bytVer(1)) & Chr(bytVer(2))
    End If
    
    Get #iFreeFile, &H15, bytDB_ID
    fsRetVer = IIf(bytDB_ID = 0, "Access97 Ver:", "Access200? Ver:") & fsRetVer
    If bytDB_ID = 1 Then
      lMax = 20
      bytSecret(0) = (&H49)
      bytSecret(1) = (&HEC)
      bytSecret(2) = (&H92)
      bytSecret(3) = (&H9C)
      bytSecret(4) = (&H9)
      bytSecret(5) = (&H28)
      bytSecret(6) = (&HDC)
      bytSecret(7) = (&H8A)
      bytSecret(8) = (&H9B)
      bytSecret(9) = (&H7B)
      bytSecret(10) = (&H3A)
      bytSecret(11) = (&HDF)
      bytSecret(12) = (&HB8)
      bytSecret(13) = (&H13)
      bytSecret(14) = (&H0)
      bytSecret(15) = (&HB1)
      bytSecret(16) = (&HFB)
      bytSecret(17) = (&H79)
      bytSecret(18) = (&H5D)
      bytSecret(19) = (&H7C)
    ElseIf bytDB_ID = 0 Then
      lMax = 13
      bytSecret(0) = (&H86)
      bytSecret(1) = (&HFB)
      bytSecret(2) = (&HEC)
      bytSecret(3) = (&H37)
      bytSecret(4) = (&H5D)
      bytSecret(5) = (&H44)
      bytSecret(6) = (&H9C)
      bytSecret(7) = (&HFA)
      bytSecret(8) = (&HC6)
      bytSecret(9) = (&H5E)
      bytSecret(10) = (&H28)
      bytSecret(11) = (&HE6)
      bytSecret(12) = (&H13)
    Else
      Close #iFreeFile
      MsgBox "你怎么打开我不知道的文件?", vbQuestion
      GoTo ErrLabel
    End If
    On Error GoTo ErrLabel
        
    '以下为解密过程
    For l = 1 To lMax
      Get #iFreeFile, &H43 + (l - 1) * (bytDB_ID + 1), bytEncrept(l - 1)
    Next l
    Close #iFreeFile
    
    For n = -1 To 255
      sTemp = ""
      DoEvents
      If (n > -1) Or (bytDB_ID = 0) Then
        frmMain.Shape1.Width = frmMain.Label5.Width * (n + 1) / 255
        For l = 1 To lMax
          n = n * bytDB_ID
          If l Mod 2 = 1 Then
            sTemp = sTemp & Chr(bytEncrept(l - 1) Xor bytSecret(l - 1) Xor n)
          Else
            sTemp = sTemp & Chr(bytEncrept(l - 1) Xor bytSecret(l - 1))
          End If
        Next l
        '将得到的密码去掉尾部的 \0x00
        sTemp = Replace(sTemp, Chr(0), "")
        If (bytDB_ID = 0) Then GoTo Endlabel
        If sTemp <> "" Then
          If INNER_CanOpenDateBase(fsDBsee, sTemp) Then
            Exit For
          Else
            sTemp = ""
          End If
        End If
      Else '先使用无密码的方式
        If INNER_CanOpenDateBase(fsDBsee, sTemp) Then
'          MsgBox "根本就没有密码，何必劳我大架呢?", vbQuestion '+ vbInformation
          Exit For
        End If
      End If
    Next n
    
Endlabel:
    INNER_GetAccessPwd = sTemp
    Exit Function
ErrLabel:
    INNER_GetAccessPwd = Err.Description
End Function

Public Function INNER_CanOpenDateBase(fsFilename As String, fsPasswd As String) As Boolean
  On Error GoTo ErrLabel
  Dim sConn As String
  #If USE_DAO Then
    Set gDAO = DAO.OpenDatabase(fsFilename, False, 0, ";pwd=" & fsPasswd)
    If Not gDAO Is Nothing Then
      INNER_CanOpenDateBase = True
      Set gDAO = Nothing
    End If
  #Else
    Set gADO = New ADODB.Connection
    sConn = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & fsFilename & _
            ";Jet OLEDB:Database Password =" & fsPasswd & ";"
    gADO.Open sConn
    If Not gADO Is Nothing Then
      INNER_CanOpenDateBase = True
      Set gADO = Nothing
    End If
  #End If
ErrLabel:
End Function