Итак если файл открывается, но Вам необходимо убрать защиту листа или книги, используйте надстройку, которую я написал:
Идея алгоритма заключается в использовании недостатка стандартного метода шифрования Excel. Программа перебирает пароли от 1 до 8 символов. Последний символ пароля подбирается из диапазона кодов от 32 до 255. Остальные символы подбираются из кодов 65 и 66. В результате используется пароль отличный от оригинального, но тем не менее рабочий. К сожалению для открытия файла, через Workbook.Open(), этот метод не подходит. Метод также не работает в Excel 2007, где используется более стойкий алгоритм шифрования. Исключение составляет французская версия Excel 2007, где из-за местных законов шифрование остается прежним.
Ниже приведен исходный код надстройки для взлома пароля в Excel:
Const MENUNAME = "ЗАЩИТА"
'Установка ярлыка меню
Sub Auto_Open()
Install
MsgBox "Меню установлено, используйте ""ЗАЩИТА->Снять защиту"" для снятия защиты с активной книги Excel и всех листов"
End Sub
'Взлом всех паролей, путем перебора.
Sub BruteForceUnprotect()
Dim ProtectedObjects As New Collection
Const LastCharStart = 32
Const LastCharFinish = 255
Application.DisplayAlerts = False
'Добавление защищенной книги в набор объектов для вскрытия
If (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows) Then
ProtectedObjects.Add ActiveWorkbook
End If
'Добавление в набор защищенных листов
On Error Resume Next
For Each WSheet In ActiveWorkbook.Worksheets
WSheet.Protect ("")
If Not WSheet.Unprotect("") Then: ProtectedObjects.Add WSheet
Next
On Error GoTo 0
'Поиск подставного пароля. Оригинальный пароль не может быть восстановлен этим способом.
For i = 1 To 255
fakepassword = FakePass(i)
If ProtectedObjects.Count = 0 Then: Exit For
For LastCharIndex = LastCharStart To LastCharFinish
Password = fakepassword & Chr(LastCharIndex)
If ProtectedObjects.Count > 0 Then
For j = 1 To ProtectedObjects.Count
If UnprotectObject(ProtectedObjects(j), Password) = True Then
ProtectedObjects.Remove (j)
If ProtectedObjects.Count > 0 Then: j = j - 1
End If
Next
End If
Next
Next
If ProtectedObjects.Count = 0 Then
MsgBox "Пароли на текущую книгу и листы сняты!"
Else
MsgBox "Похоже используется нестандартное шифрование. Защита некоторых объектов не может быть снята."
End If
Application.DisplayAlerts = True
End Sub
Function UnprotectObject(obj, pass)
UnprotectObject = False
On Error GoTo WrongPassword
obj.Unprotect pass
UnprotectObject = True
WrongPassword:
End Function
'Возвращает пароль на основе переданного числового значения
Function FakePass(Value)
Mask = 1
FakePass = ""
While Mask <= Value
If (Value And Mask) = 0 Then
FakePass = "A" & FakePass
Else
FakePass = "B" & FakePass
End If
Mask = Mask * 2
Wend
If Len(FakePass) > 0 Then: FakePass = Right(FakePass, Len(FakePass) - 1)
End Function
'Установка меню
Sub Install()
Uninstall True
AddButton MENUNAME, "Снять защиту", "BruteForceUnprotect"
AddButton MENUNAME, "Удалить меню надстройки", "Uninstall"
End Sub
'Удаление меню надстройки
Sub Uninstall(Optional silent = False)
If Not silent Then
If MsgBox("Вы действительно желаете удалить меню надстройки ?", vbYesNo) = vbNo Then
Exit Sub
End If
End If
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar").Controls(MENUNAME).Delete
On Error GoTo 0
End Sub
'Добавить пункт в меню
Sub AddButton(menu As String, submenu As String, macro As String, Optional descr As String = "")
On Error GoTo createmenu
If IsNull(Application.CommandBars("Worksheet Menu Bar").Controls(menu)) Then: GoTo createmenu
On Error GoTo create
If IsNull(Application.CommandBars("Worksheet Menu Bar").Controls(menu).Controls(submenu)) Then: GoTo create
End
createmenu:
Set mnu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=10)
mnu.Caption = "&" & menu
mnu.Visible = True
create:
Set Button = Application.CommandBars("Worksheet Menu Bar").Controls(menu).Controls.Add(Type:=1, ID:=2950)
With Button
.DescriptionText = descr
.TooltipText = descr
.Caption = "&" & submenu
.Style = 3
.OnAction = macro
End With
End Sub
