I want to Break Password of Each files of Every Sheets

[Abhijeet]

Hi

I have macro this work but i have 200 files & 5 sheets so this macro take to much time can u please tell me how to Run Fast this macro.

Sub unprotect()
Dim ws As Worksheet, strWB As Workbook
Dim myPath As String, sFile As String
Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, n As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim i4 As Integer, i5 As Integer, i6 As Integer


Application.ScreenUpdating = False
myPath = Application.ThisWorkbook.Path & "\"

sFile = Dir(myPath & "*.xl??")
If sFile = "" Then
    MsgBox "No CAF_File found!!!", vbCritical
    Exit Sub
End If

Do While sFile <> ""
    Set strWB = Workbooks.Open(myPath & sFile)
        For Each ws In strWB.Worksheets
            'ws.unprotect
            On Error Resume Next
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126

ws.unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
        Next
    strWB.Close True
sFile = Dir
Loop
Set strWB = Nothing

Application.ScreenUpdating = True
End Sub

 

[Luke M]

Any chance all the files have the same password? If so, you only have to crask it once. Your current code runs through the complete crack check for EACH worksheet. Might save some time to at least check if same password is for each sheet, and then for each workbook. See McGimpsey's code for an example of this:
http://www.mcgimpsey.com/excel/removepwords.html

 

[Abhijeet]

Password I do not know thats why i use code of password Break my macro works only take too much time so can u please tell me how run fast this macro

 

[Luke M]

Password I do not know thats why i use code of password Break my macro works only take too much time so can u please tell me how run fast this macro

As I said in last post, once you get one password figured out, you may not need to crack them all. Try the same password on all the sheets in the workbook (as often people use same password), and then I might try using same password on the workbooks.

If you look at the McGimpsey link (and based on your response, I feel like you didn't), you'll see that he provides a complete macro for cracking passwords in a workbook. It shows how to use the same password, and more important, it shows an output of the password that was found. If you used this in your tool, you would then know the password, and could try it on the other workbooks.

 

[Abhijeet]

Hi Luke M

I look at the McGimpsey link this is work Fast if 1 Password for all sheets.But now i have problem is this macro work for only 1 active workbook I want Run Enitre folder files & do not want any Message Box.Can u plaese tell me how to do this

 

[Abhijeet]

Hi Luke M

I use this macro but this work for active workbook can please tell me In 1 folder what ever files (I have more than 300 files) work this macro please tell me changes in this code
Public Sub AllInternalPasswords()

Dim w1 As Worksheet, w2 As Worksheet
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
Dim PWord1 As String
Dim ShTag As Boolean, WinTag As Boolean

Application.ScreenUpdating = False
With ActiveWorkbook
WinTag = .ProtectStructure Or .ProtectWindows
End With
ShTag = False
For Each w1 In Worksheets
ShTag = ShTag Or w1.ProtectContents
Next w1
If Not ShTag And Not WinTag Then

Exit Sub
End If

If Not WinTag Then

Else
On Error Resume Next
Do 'dummy do loop
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
With ActiveWorkbook
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If .ProtectStructure = False And _
.ProtectWindows = False Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

Exit Do 'Bypass all for...nexts
End If
End With
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error GoTo 0
End If
If WinTag And Not ShTag Then

Exit Sub
End If
On Error Resume Next
For Each w1 In Worksheets
'Attempt clearance with PWord1
w1.Unprotect PWord1
Next w1
On Error GoTo 0
ShTag = False
For Each w1 In Worksheets
'Checks for all clear ShTag triggered to 1 if not.
ShTag = ShTag Or w1.ProtectContents
Next w1
If ShTag Then
For Each w1 In Worksheets
With w1
If .ProtectContents Then
On Error Resume Next
Do 'Dummy do loop
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If Not .ProtectContents Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

For Each w2 In Worksheets
w2.Unprotect PWord1
Next w2
Exit Do 'Bypass all for...nexts
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error GoTo 0
End If
End With
Next w1
End If
MsgBox "Done"
End Sub

 

[Luke M]

First, after 500+ posts, you should know how to post your code properly using the [code] and [/code] tags.

Now, since you've got the code that works on active workbook, AND you already had code that loops through workbooks, you can just combine them.

Sub unprotect()
Dim ws As Worksheet, strWB As Workbook
Dim myPath As String, sFile As String

Application.ScreenUpdating = False
myPath = Application.ThisWorkbook.Path & "\"

sFile = Dir(myPath & "*.xl??")
If sFile = "" Then
    MsgBox "No CAF_File found!!!", vbCritical
    Exit Sub
End If

Do While sFile <> ""
    Set strWB = Workbooks.Open(myPath & sFile)
   'Run new macro
   Call AllInternalPasswords
   strWB.Close True
   sFile = Dir
Loop
Set strWB = Nothing

Application.ScreenUpdating = True
End Sub

If you don't want to see the MsgBox's (and you should at least check once, to see if the same password was used on multiple books/sheets), just comment out those lines in the AllInteralPasswords macro.

 

[Abhijeet]

Hi Luke M

Thanks for this its work perfect Only tell me one thing i do not want this (sFile = Dir(myPath & "*.xlsx?") line i want use
Application.FileDialog(msoFileDialogFolderPicker).Show
strFldName = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

Can u please tell me how to use this in ur code

 

[Luke M]

You want to change the line where you set the value for myPath, not how it gets used. Changed this block

myPath = Application.ThisWorkbook.Path & "\"

To this:

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    myPath = .SelectedItems(1) & "\"
End With

 

[Abhijeet]

Hi, Luke M

Thanks Its help to me alot Its work perfect for me

 

[Abhijeet]

Hi Luke M
My actual files 6 sheets but i want to Break Password For these Sheets Name(1-31,Payment Totals,Sickness)
because other sheets Password is not Same so macro take too much time so can tell me how to do with these sheets password break so take not too much time

 

[Luke M]

Ask whoever set the passwords originally?

If the passwords are all different, you may just be stuck with what you've got currently. I'd set it to run overnight, and you should be good.