MODULE NAME: mainFuncs
''Created by Anton Pivkach (lbeliarl@gmail.com)
Option Base 1
'Declare Function GetTickCount Lib "kernel32.dll" () As Long
Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long 'win64_bit
Public CopiedExcel As Boolean
Public RenamedZIP As Boolean
Public CreatedTMPFolder As Boolean
Public ProtectedSheets() As Long
Sub GeneralSub()
CopiedExcel = False
RenamedZIP = False
CreatedTMPFolder = False
'Check if any selection exists
If (Sheet1.CheckVBA.Value Or Sheet1.CheckWB.Value Or Sheet1.CheckWS.Value) = False Then
MsgBox "Please select at least one checkBox!", vbInformation, "Excel Unlocker"
Exit Sub
End If
ChDir (Environ("USERPROFILE") & "\Desktop")
'Select the file
Fname = Application.GetOpenFilename(filefilter:="Excel files (*.xlsx; *.xlsm), *.xlsx; *.xlsm",
MultiSelect:=False)
'Check if file selected
If Fname = False Then
Exit Sub
End If
''Check if workBook has password for opening
On Error Resume Next
Dim tmpWB As Workbook
''Disable AutoRun macro
Application.EnableEvents = False
Set tmpWB = Workbooks.Open(Fname, ReadOnly:=True, Password:="", UpdateLinks:=False,
IgnoreReadOnlyRecommended:=True)
If Err.Number > 0 Then
MsgBox "Selected Workbook is encrypted (Password for Openning)!" & vbCrLf & "This program doesn't
works with such files.", vbCritical, "Excel Unlocker"
''Return original settings (AutoRun macro)
Application.EnableEvents = True
Exit Sub
End If
On Error GoTo 0
''Check if WorkBook is in Shared mode
If tmpWB.MultiUserEditing = True Then
''Close WorkBook
tmpWB.Close saveChanges:=False
MsgBox "Selected Workbook is in Shared Mode!" & vbCrLf & "Please change mode to Exclusive (non
Shared) and try again", vbExclamation, "Excel Unlocker"
''Return original settings (AutoRun macro)
Application.EnableEvents = True
Exit Sub
End If
''Check if VBProjec protected
ProjectProtected = ProtectedVBProject(tmpWB)
''Check if WorkBook is protected
WBookProtected = PrWB(tmpWB)
''Checx if Sheets is protected
WBookSheetsProtected = PrWSheets(tmpWB)
''Close WorkBook
tmpWB.Close saveChanges:=False
Set tmpWB = Nothing
'String for output msgs
Dim OutMSG As String
OutMSG = ""
''Create Scripting Object
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
''Call procedure for each action-----------------------------
''WorkBook------------------------------
If Sheet1.CheckWB.Value = True Then
If WBookProtected = True Then
OutMSG = UnprotectWBook(Fname)
Else
OutMSG = OutMSG & vbCrLf & "Selected WorkBook has no WorkBook Password Protection."
End If
'ChangeWBStatus
WBookProtected = False
End If
''Vba-----------------------------------
If Sheet1.CheckVBA.Value = True And FSO.GetExtensionName(Fname) = "xlsm" Then
'Check whether WorkBook has VBA Project protection
If ProjectProtected = True Then
'Check whether WorkBook has Password Protection (internal ZIP encryption)
If WBookProtected = True Then
OutMSG = OutMSG & vbCrLf & UnprotectWBook(Fname)
End If
''Call VBA unlock
OutMSG = OutMSG & vbCrLf & ChangePasswordForVBA(Fname)
Else
OutMSG = OutMSG & vbCrLf & "Selected WorkBook has no VBA Project protection."
End If
End If
''WorkSheet----------------------------
If Sheet1.CheckWS.Value = True Then
If WBookSheetsProtected = True Then
'Check whether WorkBook has Password Protection (internal ZIP encryption)
If WBookProtected = True Then
OutMSG = OutMSG & vbCrLf & UnprotectWBook(Fname)
End If
''Call Sheets unlock
OutMSG = OutMSG & vbCrLf & UnprotectWSheets(Fname)
Else
OutMSG = OutMSG & vbCrLf & "Selected WorkBook has no WorkSheets Protection."
End If
End If
''Check if returning to previous state is required
If RenamedZIP = True Then
''Rename back to .xlsm file
FSO.GetFile(rename_to_zip(copy_excel_file(Fname))).Name =
FSO.GetFileName(copy_excel_file(Fname))
''Delete tmp files--------------------------
' If FSO.FolderExists(FileNameFolder & "\") Then
' FSO.deletefolder FileNameFolder
' End If
End If
If RenamedZIP Or CopiedExcel Then
OutMSG = OutMSG & vbCrLf & vbCrLf & "Unlocked file saved under the name: '" & "Unprotected_" &
FSO.GetFileName(Fname) & "' in the same folder"
End If
Set FSO = Nothing
''Return original settings (AutoRun macro)
Application.EnableEvents = True
MsgBox OutMSG, vbInformation, "Excel Unlocker"
End Sub
Function ChangePasswordForVBA(Fname As Variant) As String
Application.StatusBar = "Resetting VBA Project password..."
''Copy Excel file and Rename to ZIP
name_of_exel_file = copy_excel_file(Fname)
If name_of_exel_file = "" Then ''Missing Write acces
ChangePasswordForVBA = "Missing Write access"
Exit Function
End If
CopyFname = rename_to_zip(name_of_exel_file)
''TMP Folder
FileNameFolder = create_TMP_folder
'Object for work with ZIP file
Set oApp = CreateObject("Shell.Application")
''Set to false
ProjectFileFound = False
''Cycle trought Zip archive
For Each fileNameInZip In oApp.Namespace(CopyFname).items
'find 'xl' folder
If fileNameInZip = "xl" Then
'find vbaProject.bin
For Each subFile In fileNameInZip.Getfolder.items
'extract 'vbaProject.bin' file
If subFile = "vbaProject.bin" Or subFile = "vbaProject" Then
''Move bin file to tmp folder
oApp.Namespace(FileNameFolder).movehere subFile
ProjectFileFound = True
Exit For
End If
Next
End If
Next
''HASH for Password = 'macro'
Dim PasswordString As String
PasswordString =
"282A84CBA1CBA1345FCCB154E20721DE77F7D2378D0EAC90427A22021A46E9CE6F17188A"
''if VbaProject exists
If ProjectFileFound = True Then
tmpMSG = ""
tmpMSG = ChangeDPBValue(FileNameFolder & "\vbaProject.bin", PasswordString) ''DPB change
''Overwirte existing vbaProject.bin file
oApp.Namespace(CopyFname).items.Item("xl").Getfolder.CopyHere FileNameFolder &
"\vbaProject.bin"
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(CopyFname).items.Item("xl").Getfolder.items.Item("vbaProject.bin").Name
= "vbaProject.bin" Or _
oApp.Namespace(CopyFname).items.Item("xl").Getfolder.items.Item("vbaProject.bin").Name =
"vbaProject"
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
If tmpMSG = "" Then
ChangePasswordForVBA = "Password for VbaProject: 'macro'"
Else
ChangePasswordForVBA = tmpMSG
End If
Else
ChangePasswordForVBA = "File don't have VbaProject!"
End If
Set oApp = Nothing
Application.StatusBar = ""
End Function
Function UnprotectWBook(Fname As Variant) As String
Dim UL As Workbook
Dim lockedWB As Workbook
''Remember this WB name
Set UL = ThisWorkbook
LockedWBName = copy_excel_file(Fname)
If LockedWBName = "" Then ''Missing Write access
UnprotectWBook = "Missing Write access"
Exit Function
End If
''Disable AutoRun macro
Application.EnableEvents = False
''Disable Alerts
Application.DisplayAlerts = False
''Dissable screen updating
Application.ScreenUpdating = False
''Open Locked WB
On Error Resume Next ''Prevent error for WriteProtection Password
Set lockedWB = Workbooks.Open(LockedWBName, notify:=False, WriteResPassword:="",
UpdateLinks:=False, IgnoreReadOnlyRecommended:=True)
''Check for Write password---------------
If Err.Number <> 0 Then
'Open original file
Set lockedWB = Workbooks.Open(Fname, ReadOnly:=True, UpdateLinks:=False,
IgnoreReadOnlyRecommended:=True)
'Save as Unlocked
lockedWB.SaveAs LockedWBName, WriteResPassword:="", ReadOnlyRecommended:=False
End If
On Error GoTo 0
''Return original settings (AutoRun macro)
Application.EnableEvents = True
''Randomize HASH values to improve chance of quick break
Sheet3.Calculate
'''HASH values calculated based on algorithm described here:
'http://stackoverflow.com/questions/12852095/how-does-excels-worksheet-password-protection-work
''Sort
UL.Worksheets("hash_table").AutoFilter.Sort.SortFields.Clear
UL.Worksheets("hash_table").AutoFilter.Sort.SortFields.Add Key:= _
Range("B1:B32769"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With UL.Worksheets("hash_table").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
s_t = GetTickCount
ETR = 0
''Enable errors resuming
On Error Resume Next
Do ''Dummy loop to enable early exit from For
For i = 2 To 32769
DoEvents
''update changes by 1% Calculate ETR
If i Mod 300 = 0 Then
e_t = GetTickCount
If ETR > 0 Then
ETR = (ETR + ((32769 - i) / 300 * (s_t - e_t) / 1000)) / 2
Else
ETR = (32769 - i) / 300 * (s_t - e_t) / 1000
End If
Application.StatusBar = "WB Protection password guessing: " & Format((i / 32769), "0%") & " / Max
ETR: " & Format(TimeSerial(0, 0, ETR), "hh:mm:ss")
s_t = GetTickCount
End If
lockedWB.Unprotect UL.Worksheets("hash_table").Cells(i, 1).Value
If Not (lockedWB.ProtectWindows Or lockedWB.ProtectStructure) = True Then
UnprotectWBook = "Allowable WB Protection password: '" &
UL.Worksheets("hash_table").Cells(i, 1).Value & "'"
Application.StatusBar = "WB Protection password guessing: " & Format((i / 32769), "0%") & " ->
Success!!!"
Exit Do
End If
Next i
Loop Until 1 = 1
''Disable errors resuming
On Error GoTo 0
''Save WB
lockedWB.Close saveChanges:=True
Application.StatusBar = ""
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
Function UnprotectWSheets(Fname As Variant) As String ''Fname As Variant
Application.ScreenUpdating = False
Application.StatusBar = "Remove Sheets password..."
''Copy Excel file and Rename to ZIP
CopyFname = rename_to_zip(copy_excel_file(Fname))
''TMP Folder
FileNameFolder = create_TMP_folder
'Object for work with ZIP file
Set oApp = CreateObject("Shell.Application")
''Extract locked sheets
For i = 1 To UBound(ProtectedSheets)
DoEvents
Application.StatusBar = "Sheets Protection / extracting " & "sheet" & ProtectedSheets(i)
''Move .xml file to tmp folder
oApp.Namespace(FileNameFolder).movehere oApp.Namespace(CopyFname &
"\xl\worksheets").items.Item("sheet" & ProtectedSheets(i) & ".xml")
Next i
''Dim xmlDoc As MSXML2.DOMDocument
''Dim objNode As IXMLDOMSelection
''Process each locked sheet----------------------
''Create XML object
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
For i = 1 To UBound(ProtectedSheets)
Application.StatusBar = "Sheets Protection / removing protection of " & "sheet" & ProtectedSheets(i)
'Load XML file (sheet)
xmlDoc.Load FileNameFolder & "\sheet" & ProtectedSheets(i) & ".xml"
''Set Node sheetProtection
Set objSelecion = xmlDoc.getElementsByTagName("sheetProtection")
''Revmove node
objSelecion.removeAll
''Save changes
xmlDoc.Save FileNameFolder & "\sheet" & ProtectedSheets(i) & ".xml"
Next i
''Overwirte existing sheets in ZIP file------------------------
For i = 1 To UBound(ProtectedSheets)
Application.StatusBar = "Sheets Protection / compressing " & "sheet" & ProtectedSheets(i)
'' prevent compressing error----
On Error Resume Next
Do
oApp.Namespace(CopyFname & "\xl\worksheets").CopyHere FileNameFolder & "\sheet" &
ProtectedSheets(i) & ".xml"
DoEvents
Application.Wait (Now + TimeValue("0:00:01"))
Loop Until Err.Number = 0
On Error GoTo 0
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(CopyFname & "\xl\worksheets").items.Item("sheet" & ProtectedSheets(i) &
".xml").Name = CStr("sheet" & ProtectedSheets(i) & ".xml")
DoEvents
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
Next i
Application.StatusBar = ""
UnprotectWSheets = "All the Sheets have been unprotected"
Application.ScreenUpdating = True
End Function
MODULE NAME: auxiliaryFuncs
Option Base 1
Function ProtectedVBProject(ByRef wb As Workbook) As Boolean
' returns TRUE if the VB project in the active document is protected
Dim VBC As Integer
VBC = -1
On Error Resume Next
VBC = wb.VBProject.VBComponents.Count
On Error GoTo 0
If VBC = -1 Then
ProtectedVBProject = True
Else
ProtectedVBProject = False
End If
End Function
Function PrWB(ByRef wb As Workbook) As Boolean
PrWB = False
If wb.ProtectWindows Then PrWB = True
If wb.ProtectStructure Then PrWB = True
If PrWB = True Then
'try for password protection
On Error Resume Next
wb.Unprotect
If Err.Number = 0 Then PrWB = False
On Error GoTo 0
End If
End Function
Function PrWSheets(ByRef wb As Workbook) As Boolean
PrWSheets = False
''Arrays for storing protected wsheets
i=0
For Each SH In wb.Sheets
If SH.ProtectContents Or SH.ProtectDrawingObjects Or SH.ProtectScenarios Then
i=i+1
ReDim Preserve ProtectedSheets(i)
ProtectedSheets(i) = SH.Index
PrWSheets = True
End If
Next
End Function
Function copy_excel_file(file_to_copy)
''Create Scripting Object
'Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
'Define new name
UnprotecedFilePath = FSO.GetParentFolderName(file_to_copy) & "\Unprotected_" &
FSO.GetFileName(file_to_copy)
''Check if file already copied
If CopiedExcel = False Then
On Error Resume Next
''Copy
FSO.CopyFile file_to_copy, UnprotecedFilePath, True
''Check for access error
If Err.Number <> 0 Then
MsgBox "You have no Write access to the folder: '" & FSO.GetParentFolderName(file_to_copy) & "'",
vbCritical, "Excel Unlocker"
copy_excel_file = ""
Exit Function
End If
On Error GoTo 0
'Save flag
CopiedExcel = True
End If
Set FSO = Nothing
''return path
copy_excel_file = UnprotecedFilePath
End Function
Function rename_to_zip(file_to_rename)
''Create Scripting Object
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
''Create new name
ZIPFilePath = FSO.GetParentFolderName(file_to_rename) & "\" & FSO.GetBaseName(file_to_rename) &
".zip"
''Check if file already renamed
If RenamedZIP = False Then
'chekc if file with such name exists
If FSO.FileExists(ZIPFilePath) Then FSO.DeleteFile ZIPFilePath, True
'Change extension
FSO.MoveFile file_to_rename, ZIPFilePath
'Save flag
RenamedZIP = True
End If
Set FSO = Nothing
''Return path
rename_to_zip = ZIPFilePath
End Function
Function create_TMP_folder()
''Path to tmp folder
FileNameFolder = Environ("tmp") & "\UnlockFolderTMP"
If CreatedTMPFolder = False Then
''Create Scripting Object
'Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
''Delete if previous files exists
Do While FSO.FolderExists(FileNameFolder & "\")
FSO.deletefolder FileNameFolder
DoEvents
Application.Wait (Now + TimeValue("0:00:01")) '' wait until deletion is done
Loop
'Make the tmp folder in User tmp
FSO.CreateFolder FileNameFolder
'Destroy FSO
Set FSO = Nothing
'Set Flag
CreatedTMPFolder = True
End If
create_TMP_folder = FileNameFolder
End Function
Function ChangeDPBValue(PathToBinFile As String, HASHPassword As String) As String
''Dim adoStream As ADODB.Stream
''Dim adoBin As ADODB.Stream
Dim PasswordArrayByte() As Byte
Set adoStream = CreateObject("ADODB.Stream")
Set adoBin = CreateObject("ADODB.Stream")
ReDim PasswordArrayByte(Len(HASHPassword))
''Convert String to byte
For i = 1 To Len(HASHPassword)
PasswordArrayByte(i) = Asc(Mid(HASHPassword, i, 1))
Next i
''Read TXT data fine 'DPB' value
With adoStream
.Mode = 3 'adModeReadWrite
.Type = 2 'adTypeText
.Charset = "us-ascii"
.Open
.LoadFromFile (PathToBinFile)
bytes = .ReadText
''Find Start of Value pos
StartPosVal = InStr(1, bytes, "DPB=", vbTextCompare) + 5
''IF there is no DPB value
If StartPosVal = 5 Then
.Close
Set adoStream = Nothing
Set adoBin = Nothing
ChangeDPBValue = "VBA Protection Not found"
Exit Function
End If
''Find End of Value pos
EndPosVal = InStr(StartPosVal, bytes, """", vbTextCompare) - 1
'Define lenght
ValLength = EndPosVal - StartPosVal + 1
If Len(HASHPassword) < ValLength Then
'add additional '0' if coded password is longer
ReDim Preserve PasswordArrayByte(Len(HASHPassword) + ValLength - Len(HASHPassword))
For i = Len(HASHPassword) + 1 To UBound(PasswordArrayByte)
PasswordArrayByte(i) = Asc(0)
Next i
End If
.Close
End With
''Read binary data
With adoStream
.Mode = 3 'adModeReadWrite
.Type = 1 'adTypeBinary
.Open
.LoadFromFile (PathToBinFile)
''Create empty stream object
With adoBin
.Mode = 3 'adModeReadWrite
.Type = 1 'adTypeBinary
.Open
End With
'copy first part of bytes (till start of 'DPB' value)
.Position = 0
.CopyTo adoBin, StartPosVal - 1
'copy new DPB value
adoBin.Write (PasswordArrayByte)
'copy remaining part of bytes (after 'DPB' value)
.Position = EndPosVal ''Set position to remaining part
.CopyTo adoBin
'save to file
adoBin.SaveToFile PathToBinFile, 2 'adSaveCreateOverWrite
adoBin.Close
.Close
End With
Set adoStream = Nothing
Set adoBin = Nothing
ChangeDPBValue = ""
End Function
'Sub Auto_Open()
'
''''Add ADO library if required---------------------------------------------
''ADOAssigned = False
''
''For i = 1 To ThisWorkbook.VBProject.References.Count
'' ''Debug.Print ThisWorkbook.VBProject.References.Item(i).Name
'' If ThisWorkbook.VBProject.References.Item(i).Name = "ADODB" Then
'' ADOAssigned = True
'' End If
''Next i
''
''If ADOAssigned = False Then
'' ThisWorkbook.VBProject.References.AddFromFile Environ("CommonProgramFiles") &
"\System\ado\msado15.dll"
''End If
'
'
'End Sub
