VBAProject密码清除 for EXCEL2003
下载了多个⼯具都是浮云，只有这个好⽤
⽂章转载于⽹络
在空⽩excel⽂档vba⾥⾯插⼊模块，运⾏此模块
Option Explicit
Const LANG_ENGLISH As Integer = 9
Type CommandLineInfo
Name As String
Value As String
StartPos As Long
End Type
Sub main()
Dim fName As String
fName = Application.GetOpenFilename("Excel⽂件（xls ; xla）,*.xls;*.xla", , "选择要破解的EXCEL2003包含VBA密码的⽂件")
If fName = "False" Then Exit Sub
Dim fNewName As String
fNewName = MoveProtect(fName)
If Len(fNewName) Then
If MsgBox("转换完成，另存为：" & vbLf & fNewName & vbLf & "要打开吗？", vbQuestion + vbYesNo, "完成") = vbYes Then Workbooks.Open fNewName
Else
MsgBox "未发现VBAProject有密码特征字符串", vbInformation, "提⽰"
End If
End Sub
Private Function MoveProtect(fName As String) As String
Dim myExcelFileData As String
Dim myCommandLinesInfo() As CommandLineInfo
myExcelFileData = GetFileData(fName)
If SearchSpecificCommandInfo(myExcelFileData, myCommandLinesInfo) Then
MoveProtect = Write2File(Left(fName, Len(fName) - 4) & "_覆盖VBA密码.xls", CoverData(myExcelFileData, myCommandLinesInfo)) End If
End Function
Private Function GetFileData(fName As String) As String
Dim DAT() As Byte
ReDim DAT(1 To FileLen(fName))
Open fName For Binary As #1
Get #1, , DAT
Close
GetFileData = StrConv(DAT, vbUnicode, LANG_ENGLISH)
End Function
Private Function SearchSpecificCommandInfo(Content As String, myCommandLinesInfo() As CommandLineInfo) As Boolean
Dim i As Long
Dim objRegEx As Object, m As Object
Dim m0 As String, m0StartPos As Long
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.IgnoreCase = True
objRegEx.Pattern = CreateSearchCommandPattern()
Set m = objRegEx.Execute(Content)
If m.Count Then
m0 = m(0).Value
m0StartPos = m(0).firstindex + 1
ReDim myCommandLinesInfo(1 To 4)
For i = 1 To 4
With myCommandLinesInfo(i)
.Value = m(0).submatches(i - 1)
.StartPos = m0StartPos + InStr(1, m0, .Value) - 1
End With
Next
End If
Set m = Nothing
Set objRegEx = Nothing
SearchSpecificCommandInfo = m0StartPos > 0
End Function
Private Function CreateSearchCommandPattern() As String
Dim p(1 To 4) As String
Dim myPattern As String
Dim i As Integer
p(1) = "ID=""{00000000-0000-0000-0000-000000000000}"""
p(2) = "CMG"
p(3) = "DPB"
密码字符串是什么p(4) = "GC"
For i = 1 To 4
myPattern = myPattern & "(" & p(i) & IIf(i > 1, "=""[a-z0-9]+""", "") & ")" & vbCrLf & "[\s\S]*?"
Next
CreateSearchCommandPattern = myPattern & "[Host Extender Info]"
End Function
Private Function CoverData(Content As String, myCommandLinesInfo() As CommandLineInfo) As Byte() Dim i As Long
Dim s As String
s = Content
For i = LBound(myCommandLinesInfo) To UBound(myCommandLinesInfo)
With myCommandLinesInfo(i)
Mid(s, .StartPos, Len(.Value)) = CreateFillContent(Len(.Value))
End With
Next
CoverData = StrConv(s, vbFromUnicode, LANG_ENGLISH)
End Function
Private Function CreateFillContent(ContentLen As Long) As String
CreateFillContent = Replace(Space(ContentLen \ 2), " ", vbCrLf) & IIf(ContentLen Mod 2, Chr(32), "") End Function
Private Function Write2File(fName As String, DAT() As Byte) As String
If Dir(fName) <> "" Then Kill fName
Open fName For Binary As #1
Put #1, , DAT
Close
Write2File = fName
End Function
版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。
发表评论