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