MODULE NAME: mainFuncs

''Created by Anton Pivkach ([email protected])

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