www.pudn.com > QQ2005Pwd.rar > modAccessFinality.bas
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
Public 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