标题: VBAProject密码清除 for EXCEL2003 [打印本页] 作者: 风火石 时间: 2019-1-15 21:49 标题: 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