VBAProject密码清除 for EXCEL2003

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