PDA

View Full Version : Lỡ quên password khi Protect sheet thì làm sao?



Pansy_flower
20-06-06, 08:51 PM
Password (phần I)



Module mở password của EDC, nhằm giúp các bạn học hỏi.
Lắm lúc khi tôi Protect một sheet, quên password,...đúng là dở khóc dở cười.
Các bạn hãy download Add-in này về mà sử dụng:
Http://WWW.Erlandsenddata.no (http://www.erlandsenddata.no/)

Trong chương trình có 3 form và 4 module.

Module modMenu:


' Purpose: Create the main menu and add the tool menu
' ------------------------------------------------------------
' Author: Ole P. Erlandsen, ope@erlandsendata.no
' Company: Erlandsen Data Consulting, http://www.erlandsendata.no
' Revision History:
' 1998-12-11 OPE: Created.
' 2002-05-08 OPE: Updated.
' ------------------------------------------------------------
Option Explicit

Public Const EDCMenuTag As String = "EDC_menu"
Public Const EDCToolTag As String = "EDC_PasswordTool" ' a unique tool identification

Sub CreateMenuPasswordTool()
' creates your custom menu, duplicate this procedure for each menu you want to create
Dim cbm As CommandBarPopup, cbMenu As CommandBarPopup, cbSubMenu As CommandBarPopup
On Error Resume Next
Set cbm = GetEDCMenu(Application.CommandBars.ActiveMenuBar) ' returns/creates the main menu
On Error GoTo 0
If cbm Is Nothing Then Exit Sub
DeleteCommandBarControl Application.CommandBars.ActiveMenuBar, EDCToolTag ' delete the custom menu if it already exists
On Error Resume Next
Set cbMenu = cbm.Controls.Add(msoControlPopup, , , , True)
On Error GoTo 0
If cbMenu Is Nothing Then Exit Sub ' could not create/find the menu
With cbMenu
Select Case ICS
Case 47
.Caption = "&Passord"
Case Else
.Caption = "&Password"
End Select
.Tag = EDCToolTag
.BeginGroup = False
End With

'add a menuitem to the menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)
Select Case ICS
Case 47
.Caption = "Den &aktive arbeidsboken..."
Case Else
.Caption = "The &active workbook..."
End Select
.OnAction = "'" & ThisWorkbook.Name & "'!UnprotectInActiveWorkbook"
.Style = msoButtonIconAndCaption
.FaceId = 225
End With

'add a menuitem to the menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)
Select Case ICS
Case 47
.Caption = "En &beskyttet arbeidsbok..."
Case Else
.Caption = "A &protected workbook..."
End Select
.OnAction = "'" & ThisWorkbook.Name & "'!OpenProtectedWB"
.Style = msoButtonIconAndCaption
.FaceId = 23
End With

' default menu code'
' add a menuitem to the menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)
.BeginGroup = True
Select Case ICS
Case 47
.Caption = "&Hjelp..."
Case Else
.Caption = "&Help..."
End Select
.OnAction = "'" & ThisWorkbook.Name & "'!HelpThisWorkbookPasswordTool"
.Style = msoButtonIconAndCaption
.FaceId = 49
End With

' add a menuitem to the menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)
Select Case ICS
Case 47
.Caption = "&Om " & ThisWorkbook.Name & "..."
Case Else
.Caption = "&About " & ThisWorkbook.Name & "..."
End Select
.OnAction = "'" & ThisWorkbook.Name & "'!AboutThisWorkbookPasswordTool"
.Style = msoButtonIconAndCaption
.FaceId = 487
End With

' add a menuitem to the menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)
Select Case ICS
Case 47
.Caption = "&Lukk " & ThisWorkbook.Name
Case Else
.Caption = "&Close " & ThisWorkbook.Name
End Select
.OnAction = "'" & ThisWorkbook.Name & "'!CloseThisWorkbookPasswordTool"
.Style = msoButtonIconAndCaption
.FaceId = 1088
End With

Set cbSubMenu = Nothing
Set cbMenu = Nothing
End Sub

Private Sub RemoveThisMenuPasswordTool() ' used by the menu to remove itself
DeleteCommandBarControl Nothing, EDCToolTag
DeleteEmptyEDCMenus
End Sub
Private Function GetEDCMenu(cb As CommandBar) As CommandBarPopup
' returns the main menu control

Dim cbMenu As CommandBarPopup
If cb Is Nothing Then Exit Function
Set cbMenu = cb.FindControl(, , EDCMenuTag, True, True)
If cbMenu Is Nothing Then
On Error Resume Next
Set cbMenu = cb.Controls.Add(msoControlPopup, , , , True)
On Error GoTo 0
End If
If Not cbMenu Is Nothing Then
With cbMenu
Select Case ICS
Case 47
.Caption = "&EDC"
.TooltipText = "Verktøy fra Erlandsen Data Consulting"
Case Else
.Caption = "&EDC"
.TooltipText = "Tools from Erlandsen Data Consulting"
End Select
.Tag = EDCMenuTag
.BeginGroup = False
End With
Set GetEDCMenu = cbMenu
End If
Set cbMenu = Nothing
End Function Sub DeleteEmptyEDCMenus()

' deletes the main menu if it is empty

Dim cb As CommandBar, cbm As CommandBarPopup
Select Case ICS
Case 47
Application.StatusBar = "Rydder i menyene..."
Case Else
Application.StatusBar = "Cleaning menus..."
End Select
For Each cb In Application.CommandBars
Set cbm = cb.FindControl(, , EDCMenuTag, False, True)
If Not cbm Is Nothing Then
If cbm.Controls.Count = 0 Then
On Error Resume Next
cbm.Delete
On Error GoTo 0
End If
End If
Next cb
Set cb = Nothing
Application.StatusBar = False
End Sub

Sub DeleteCommandBarControl(cb As CommandBar, strTag As String)
' deletes commandbar controls with a tag = strTag from cb
Dim c As CommandBarControl
If cb Is Nothing Then ' delete ALL occurences
Set c = Application.CommandBars.FindControl(, , strTag, False)
Do While Not c Is Nothing
On Error Resume Next
c.Delete
On Error GoTo 0
Set c = Application.CommandBars.FindControl(, , strTag, False)
Loop
Else ' delete from one commandbar
Set c = cb.FindControl(, , strTag, False, True)
Do While Not c Is Nothing
On Error Resume Next
c.Delete
On Error GoTo 0
Set c = cb.FindControl(, , strTag, False, True)
Loop
End If
Set c = Nothing
End Sub




(Trích bài của anh Lê Văn Duyệt)

Pansy_flower
20-06-06, 08:56 PM
Password phần II




Private Function ICS() As Integer
ICS = Application.International(xlCountrySetting)
End Function

Sub HelpThisWorkbookPasswordTool()
' displays help information if it exists, no editing necessary
Dim HelpSheet As String
Application.ScreenUpdating = False
On Error GoTo NoHelp
Select Case Application.International(xlCountrySetting)
Case 1: HelpSheet = "Help" ' english
Case 47: HelpSheet = "Help" ' could have been the norwegian edition...
Case Else: HelpSheet = "Help" ' unsupported
End Select
ThisWorkbook.Worksheets(HelpSheet).Copy
With ActiveWindow
.DisplayWorkbookTabs = False
.DisplayHeadings = False
.DisplayGridlines = False
End With
With ActiveSheet
.EnableSelection = xlUnlockedCells
.Protect
End With
ActiveWorkbook.Saved = True
Application.ScreenUpdating = True
Exit Sub
NoHelp:
AboutThisWorkbookPasswordTool
End Sub

Sub AboutThisWorkbookPasswordTool()
Load frmAboutEDC
frmAboutEDC.Show
Unload frmAboutEDC
End Sub

Sub CloseThisWorkbookPasswordTool()
On Error Resume Next
ThisWorkbook.Close True
On Error GoTo 0
End Sub

Sub ExpiredWorkbook()
' closes ThisWorkbook if Date>ExpirationDate
' presents an alert message if Date>ExpirationDate-32
Dim ExpirationDate As Long
ExpirationDate = DateSerial(2006, 7, 1)
'Ngay het han la 01/07/2006 (dd/mm/yyyy)
If CLng(Date) > ExpirationDate Then
MsgBox "This workbook has expired!" & Chr(13) & Chr(13) & _
"You can get an updated version at this website:" & Chr(13) & _
"http://www.erlandsendata.no/", vbExclamation, ThisWorkbook.Name
ThisWorkbook.Close False
End
Else
If CLng(Date) > ExpirationDate - 32 Then
MsgBox "This workbook will expire on " & Format(ExpirationDate, "d. mmmm yyyy") & "!" & Chr(13) & Chr(13) & _
"You can get an updated version at this website:" & Chr(13) & _
"http://www.erlandsendata.no/", vbExclamation, ThisWorkbook.Name
End If
End If
End Sub

Module Password
' Purpose: Remove passwords from a protected workbook
' Returns: An unprotected workbook/sheets
' ------------------------------------------------------------
' Author: Ole P. Erlandsen, ope@erlandsendata.no
' Company: Erlandsen Data Consulting, http://www.erlandsendata.no
' Revision History:
' 1998-12-05 OPE: Created.
' 2000-01-04 OPE: Edited.
' 2000-03-03 OPE: Edited.
' 2000-10-16 OPE: Edited.
' ------------------------------------------------------------
Option Explicit

Public atCountMrd As Long, atCount As Long
Public FoundPassword() As String, fpCount As Integer
Dim pwdBook As Workbook
Dim StartTime As Double, LastSBmsg As Double

Sub OpenProtectedWB()
Load frmOpenProtectedWB
frmOpenProtectedWB.Show
Unload frmOpenProtectedWB
End Sub

Sub UnprotectInActiveWorkbook()
Load frmProtectedWorkbook
frmProtectedWorkbook.Show
Unload frmProtectedWorkbook
End Sub

Sub FindWorkbookPasswords(TargetWB As Workbook, fWB As Boolean, _
fSht As Boolean, fShtType As Integer)
Dim i As Integer, pwd As String, SHT As Object, OK As Boolean, pwdTextFile As String
Dim UseTextFile As Boolean
ExpiredWorkbook
If TargetWB Is Nothing Then Exit Sub
If fShtType < 1 Or fShtType > 4 Then Exit Sub
Application.ScreenUpdating = False
atCountMrd = 0
atCount = 0
LastSBmsg = 0
pwdTextFile = ReadFromRegistry("EDC Tools", "PasswordTool", "PasswordFile")
UseTextFile = ReadFromRegistry("EDC Tools", "PasswordTool", "UsePasswordFile") = "1"
StartTime = Now
' remove sharing password if necessary
If TargetWB.MultiUserEditing Then ' try to find the sharing password
Application.DisplayAlerts = False
pwd = ""
If pwdTextFile <> "" And UseTextFile Then
pwd = TestPasswordsFromTextFile(pwdTextFile, 4, TargetWB, Nothing)
End If
If Len(pwd) > 0 Then
PresenterResultat "Workbook share password", pwd, False
Else
pwd = RemovePassWords(4, TargetWB, Nothing, "Searching for share password in " & TargetWB.Name & " : ")
PresenterResultat "Workbook share password", pwd, True
End If
Application.DisplayAlerts = True
End If
If TargetWB.MultiUserEditing Then
' can't find the other passwords if the workbook is still shared
AvsluttPresentasjon
MsgBox "Can't find passwords in this shared workbook." & Chr(13) & _
"Open the workbook with exclusive access and try again.", _
vbExclamation, TargetWB.Name & " is a shared workbook!"
Exit Sub
End If
If fWB Then ' find workbook protection password
If TestWorkbookPassword(TargetWB, "") = False Then
pwd = TestFoundPasswords(2, TargetWB, Nothing)
If Len(pwd) > 0 Then
PresenterResultat TargetWB.Name, pwd, False
Else ' test passwords from the text file
pwd = ""
If pwdTextFile <> "" And UseTextFile Then
pwd = TestPasswordsFromTextFile(pwdTextFile, 2, TargetWB, Nothing)
End If
If Len(pwd) > 0 Then
PresenterResultat TargetWB.Name, pwd, False
Else
pwd = RemovePassWords(2, TargetWB, Nothing, "Searching for password in " & TargetWB.Name & " : ")
PresenterResultat TargetWB.Name, pwd, True
End If
End If
End If
End If
If fSht Then ' find sheet protection passwords
If fShtType = 2 Then ' activesheet only
SheetPasswordTest TargetWB.ActiveSheet, "Searching for password in " & TargetWB.ActiveSheet.Name & " (active sheet):", pwdTextFile
Else ' all sheets
i = 0
For Each SHT In TargetWB.Sheets
i = i + 1
SheetPasswordTest SHT, "Searching for password in " & SHT.Name & " (" & i & " of " & TargetWB.Sheets.Count & "): ", pwdTextFile
Next SHT
Set SHT = Nothing
End If
End If
AvsluttPresentasjon
End Sub

Private Sub SheetPasswordTest(TargetSheet As Object, sbMsg As String, pwdTextFile As String)
' tester passord i et enkelt ark
Dim pwd As String, UseTextFile As Boolean
UseTextFile = ReadFromRegistry("EDC Tools", "PasswordTool", "UsePasswordFile") = "1"
If ProtectedSheet(TargetSheet) Then
pwd = TestFoundPasswords(3, TargetSheet.Parent, TargetSheet)
If Len(pwd) > 0 Then
PresenterResultat TargetSheet.Name, pwd, False
Else ' test passwords from the text file
pwd = ""
If pwdTextFile <> "" And UseTextFile Then
pwd = TestPasswordsFromTextFile(pwdTextFile, 3, TargetSheet.Parent, TargetSheet)
End If
If Len(pwd) > 0 Then
PresenterResultat TargetSheet.Name, pwd, False
Else ' test "all" passwords
pwd = RemovePassWords(3, TargetSheet.Parent, TargetSheet, sbMsg)
PresenterResultat TargetSheet.Name, pwd, True
End If
End If
End If
End Sub




(Trích bài của anh Lê Văn Duyệt)

Pansy_flower
20-06-06, 08:59 PM
Password phần III


Private Function RemovePassWords(pwType As Integer, wb As Workbook, WBS As Object, sbMsg As String) As String
' pwType = 2 : fjerner passord fra arbeidsbøker
' pwType = 3 : fjerner passord fra ark
' pwType = 4 : fjerner delingspassord
Const lowChr2 As Integer = 32
Const highChr2 As Integer = 255
Dim lowChr1 As Integer, highChr1 As Integer
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim m As Integer, N As Integer, o As Integer, p As Integer
Dim pwFound As Boolean, pwText As String
lowChr1 = 97 '33
highChr1 = 98 ' 34
RemovePassWords = ""
'On Error Resume Next
Application.EnableCancelKey = xlErrorHandler
On Error GoTo HandleESC
Application.Calculation = xlManual
Application.ScreenUpdating = False
pwFound = TestPassword(pwType, wb, WBS, "", sbMsg)
If Not pwFound Then
For i = lowChr2 To highChr2
pwText = Chr(i)
pwFound = TestPassword(pwType, wb, WBS, pwText, sbMsg)
If pwFound Then Exit For
Next
End If
If Not pwFound Then
For i = lowChr1 To highChr1
For j = lowChr2 To highChr2
pwText = Chr(i) + Chr(j)
pwFound = TestPassword(pwType, wb, WBS, pwText, sbMsg)
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
End If
If Not pwFound Then
For i = lowChr1 To highChr1: For j = lowChr1 To highChr1
For k = lowChr2 To highChr2
pwText = Chr(i) + Chr(j) + Chr(k)
pwFound = TestPassword(pwType, wb, WBS, pwText, sbMsg)
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
End If
If Not pwFound Then
For i = lowChr1 To highChr1: For j = lowChr1 To highChr1: For k = lowChr1 To highChr1
For l = lowChr2 To highChr2
pwText = Chr(i) + Chr(j) + Chr(k) + Chr(l)
pwFound = TestPassword(pwType, wb, WBS, pwText, sbMsg)
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
End If
If Not pwFound Then
For i = lowChr1 To highChr1: For j = lowChr1 To highChr1: For k = lowChr1 To highChr1: For l = lowChr1 To highChr1
For m = lowChr2 To highChr2
pwText = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m)
pwFound = TestPassword(pwType, wb, WBS, pwText, sbMsg)
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
End If
If Not pwFound Then
For i = lowChr1 To highChr1: For j = lowChr1 To highChr1: For k = lowChr1 To highChr1: For l = lowChr1 To highChr1: For m = lowChr1 To highChr1
For N = lowChr2 To highChr2
pwText = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr(N)
pwFound = TestPassword(pwType, wb, WBS, pwText, sbMsg)
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
End If
If Not pwFound Then
For i = lowChr1 To highChr1: For j = lowChr1 To highChr1: For k = lowChr1 To highChr1: For l = lowChr1 To highChr1: For m = lowChr1 To highChr1: For N = lowChr1 To highChr1
For o = lowChr2 To highChr2
pwText = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr(N) + Chr(o)
pwFound = TestPassword(pwType, wb, WBS, pwText, sbMsg)
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
End If
If Not pwFound Then
For i = lowChr1 To highChr1: For j = lowChr1 To highChr1: For k = lowChr1 To highChr1: For l = lowChr1 To highChr1
For m = lowChr1 To highChr1: For N = lowChr1 To highChr1: For o = lowChr1 To highChr1
For p = lowChr2 To highChr2
pwText = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr(N) + Chr(o) + Chr(p)
pwFound = TestPassword(pwType, wb, WBS, pwText, sbMsg)
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
If pwFound Then Exit For
Next
End If
Application.StatusBar = False
Application.Calculation = xlAutomatic
If pwFound Then
RemovePassWords = pwText
End If
Exit Function
HandleESC:
If Err = 18 Then AvsluttPresentasjon
End Function


(Trích bài của anh Lê Văn Duyệt)

Pansy_flower
20-06-06, 09:02 PM
Password phần IV


Function TestPassword(pwType As Integer, wb As Workbook, WBS As Object, testPWD As String, sbMsg As String) As Boolean
' pwType= 2:Proteced workbook, 3:Protected sheet, 4:Share protection
Dim OK As Boolean
TestPassword = False
If Now - LastSBmsg > 5 / 86400 Then
Application.StatusBar = sbMsg & " Elapsed time: " & Format(Now - StartTime, "hh:mm:ss")
LastSBmsg = Now
End If
atCount = atCount + 1
If atCount = 1000000000 Then
atCount = 0
atCountMrd = atCountMrd + 1
End If
If pwType = 2 Then
OK = TestWorkbookPassword(wb, testPWD)
End If
If pwType = 3 Then
OK = TestSheetPassword(WBS, testPWD)
End If
If pwType = 4 Then
OK = TestSharePassword(wb, testPWD)
End If
If OK Then ' a password is found
fpCount = fpCount + 1
ReDim Preserve FoundPassword(1 To fpCount)
FoundPassword(fpCount) = testPWD
End If
TestPassword = OK
End Function

Private Function TestWorkbookPassword(wb As Workbook, testPWD As String) As Boolean
On Error Resume Next
wb.Unprotect testPWD
TestWorkbookPassword = Not (wb.ProtectStructure Or wb.ProtectWindows)
On Error GoTo 0
End Function

Private Function TestSheetPassword(WBS As Object, testPWD As String) As Boolean
On Error Resume Next
TestSheetPassword = False
TestSheetPassword = WBS.Unprotect(testPWD)
On Error GoTo 0
End Function

Private Function ProtectedSheet(WBS As Object) As Boolean
ProtectedSheet = True
On Error GoTo Beskyttet
WBS.Unprotect Empty
ProtectedSheet = False
Beskyttet:
On Error GoTo 0
End Function

Private Function TestSharePassword(wb As Workbook, testPWD As String) As Boolean
' assumes MultiUserEditing is enabled and ExclusiveAccess is granted
' recommended to turn off DisplayAlerts too
On Error Resume Next
wb.UnprotectSharing testPWD
TestSharePassword = Not wb.MultiUserEditing
On Error GoTo 0
End Function

Private Sub PresenterResultat(Beskriv As String, PassOrd As String, LagrePwd As Boolean)
Dim pwdTextFile As String, LRN As Long
If PassOrd = "" Then Exit Sub
On Error Resume Next
On Error GoTo 0
If pwdBook Is Nothing Then
Application.StatusBar = "Creating report workbook..."
Set pwdBook = Workbooks.Add
Application.DisplayAlerts = False
While pwdBook.Worksheets.Count > 1
pwdBook.Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
If pwdBook.Worksheets.Count < 1 Then pwdBook.Worksheets.Add
Application.StatusBar = False
End If
Application.StatusBar = "Writing password information..."
With pwdBook.Worksheets(1)
LRN = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(LRN, 1).Formula = Beskriv
.Cells(LRN, 2).Formula = PassOrd
.Cells(LRN, 3).Formula = CHRstring(PassOrd)
.Cells(LRN, 4).Formula = AttemptCount
.Cells(LRN, 4).NumberFormat = "#,##0"
.Cells(LRN, 5).Formula = Format(Now - StartTime, "hh:mm:ss")
End With
If LagrePwd Then
pwdTextFile = ReadFromRegistry("EDC Tools", "PasswordTool", "PasswordFile")
SavePasswordToTextFile pwdTextFile, PassOrd
End If
Application.StatusBar = "Testing for next password..."
End Sub

Private Sub AvsluttPresentasjon()
Application.StatusBar = False
If pwdBook Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.StatusBar = "Formatting the result..."
With pwdBook.Worksheets(1)
.Range("A1").Formula = "Description:"
.Range("B1").Formula = "Password:"
.Range("C1").Formula = "Password ASCII Characters:"
.Range("D1").Formula = "Total Attempts:"
.Range("E1").Formula = "Elapsed Time:"
.Range("A1:E1").Font.Bold = True
.Columns("A:E").AutoFit
.Range("A1").Select
End With
fpCount = 0
Erase FoundPassword
Application.StatusBar = False
MsgBox "You can find the password details in the workbook named " & pwdBook.Name, vbInformation, "Password(s) found in " & AttemptCount & " attempts!"
Set pwdBook = Nothing
End Sub

Private Function CHRstring(InputString As String) As String
Dim i As Integer, tString As String
tString = ""
For i = 1 To Len(InputString)
tString = tString & Asc(Mid(InputString, i, 1)) & " "
Next i
CHRstring = tString
End Function

Private Function AttemptCount() As String
AttemptCount = ""
On Error Resume Next
If atCountMrd > 0 Then
AttemptCount = atCountMrd & " " & Format(atCount, "000 000 000")
Else
AttemptCount = atCount
End If
End Function

Private Function TestFoundPasswords(pwType As Integer, wb As Workbook, WBS As Object) As String
Dim p As Integer, OK As Boolean
TestFoundPasswords = ""
OK = False
p = 1
Do While p <= fpCount And Not OK
Select Case pwType
Case 3
OK = TestSheetPassword(WBS, FoundPassword(p))
Case 2
OK = TestWorkbookPassword(wb, FoundPassword(p))
Case 4
OK = TestSharePassword(wb, FoundPassword(p))
End Select
' tell forsøket
atCount = atCount + 1
If atCount = 1000000000 Then
atCount = 0
atCountMrd = atCountMrd + 1
End If
If Not OK Then
p = p + 1
End If
Loop
If OK Then
TestFoundPasswords = FoundPassword(p)
End If
End Function

Module RegistrySettings, đây là các thủ tục và hàm mà các chương trình viết trên Excel thường sử dụng.
' macros written 2000-03-03 by Ole P. Erlandsen, ope@edc.bizhosting.com
Option Explicit

Sub WriteToRegistry(AppName As String, Section As String, Key As String, Setting As String)
' saves information in the Registry to
' HKEY_CURRENT_USER\Software\VB and VBA Program Settings\AppName
On Error Resume Next
SaveSetting AppName, Section, Key, Setting
On Error GoTo 0
End Sub

Function ReadFromRegistry(AppName As String, Section As String, Key As String) As String
' reads information in the Registry from
' HKEY_CURRENT_USER\Software\VB and VBA Program Settings\AppName
ReadFromRegistry = ""
On Error Resume Next
ReadFromRegistry = GetSetting(AppName, Section, Key, "")
On Error GoTo 0
End Function

Sub DeleteFromRegistry(AppName As String, Section As String)
' deletes information in the Registry from
' HKEY_CURRENT_USER\Software\VB and VBA Program Settings\AppName\Section
On Error Resume Next
DeleteSetting AppName, Section ' delete one section
On Error GoTo 0
End Sub

Module TextFilePassWords,
' Purpose: Unprotect a workbook with passwords from a text file
' Returns:
' ------------------------------------------------------------
' Author: Ole P. Erlandsen, ope@erlandsendata.no
' Company: Erlandsen Data Consulting, http://www.erlandsendata.no (http://www.erlandsendata.no/)
' Revision History:
' 2000-03-03 OPE: Created.
' 2000-10-16 OPE: Edited.
' ------------------------------------------------------------
Option Explicit

Function TestPasswordsFromTextFile(PassWordFile As String, _
pwType As Integer, wb As Workbook, WBS As Object) As String
Dim fn As Integer, pwd As String, OK As Boolean
TestPasswordsFromTextFile = ""
If Dir(PassWordFile) = "" Then Exit Function ' file not found
fn = FreeFile()
Open PassWordFile For Input Access Read Lock Write As #fn
OK = False
While Not EOF(fn) And Not OK
Line Input #fn, pwd ' les en linje fra tekstfilen
If Len(pwd) > 0 Then
OK = TestPassword(pwType, wb, WBS, pwd, "Testing passwords from " & PassWordFile & "...")
End If
Wend
Close #fn
If OK Then TestPasswordsFromTextFile = pwd
End Function

Sub SavePasswordToTextFile(PassWordFile As String, pwd As String)
Dim fn As Integer
fn = FreeFile()
On Error Resume Next
Open PassWordFile For Append Access Write Lock Write As #fn
Print #fn, pwd ' skriv passordet til filen
Close #fn
On Error GoTo 0
End Sub
Và cuối cùng một điều quan trọng là, khi chương trình báo cho bạn biết password thì bạn sẽ cảm thấy ngạc nhiên. Bạn sẽ tự hỏi, đây không phải là password của tôi ?! Các bạn hãy tìm hiểu và sẽ khám phá ra một điều gì đó.

Chúc các bạn thích thú ! Và đang mong chờ sự khám phá của các bạn.

Lê Văn Duyệt.
levanduyet@yahoo.com (levanduyet@yahoo.com)

PhanTuHuong
21-06-06, 07:38 PM
Theo mình, lỡ có quên pass thì phần mềm phá khóa có nhiều (nhưng cũng hơi buồn!!), chạy 1 giây ra hết. Bao chương trình với bao nhiêu công sức đều phơi code hết. Mình cũng học được từ các ứng dụng VBA phá khóa mà --=0

workman
30-06-06, 02:23 PM
Các phần mềm bẻ khóa và đoạn code ở trên chỉ có tác dụng mở những khóa "bình thường". Đoạn code của secret có 3 thuật toán, một là bỏ phần shareworksheet, hai là dò tìm trong list password có sẵn, ba là dò từng chữ một.

Các phần mềm bẻ khóa như bạn phantuhuong đề cập cũng hoạt động dựa trên nguyên tắc này.

Như đã nói ở trên, các loại thuật toán này gần như bó tay trước những password chuyên nghiệp, i.e. phải trên 8 ký tự, ít nhât 1 chữ hoa, ít nhất một ký tự wildcard...

levanduyet
01-07-06, 10:44 AM
Như đã nói ở trên, các loại thuật toán này gần như bó tay trước những password chuyên nghiệp, i.e. phải trên 8 ký tự, ít nhât 1 chữ hoa, ít nhất một ký tự wildcard...
Thật sự ra, có "khóa" phải có "mở". Vấn đề chỉ là thời gian và thủ thuật mà thôi.
Phần code trên chỉ là gở pw của mình tạo ra và chỉ là đối phó với những "người ngay".
Thân,

Lê Văn Duyệt

PhanTuHuong
07-08-06, 10:58 PM
Tôi đã thử pass trong VBA với trên 20 ký tự, toàn ký tự lằng nhằng như $!@,... nhưng chẳng có ý nghĩa gì cả, chỉ khoảng 1 giây là ra hết. Cậu minhtu còn phát hiện ra cách pass trong VBA mà không cần phần mềm phá khoá mà vẫn mở được.

Đành chịu vậy :.,

bigstream
11-08-06, 04:08 PM
Chào các pác, e mới gia nhập diễn đàn của mình. Các pác viết chương trình hay thật,nhưng e ko biết đưa code các pác viết vào excel để chạy, các pác chỉ e với. Hiện e đang có 1 file .xla dùng để remove pass protect workbook va sheet, không cần biết pass dài bao nhiêu kí tự, dùng rất hay, e xin gửi đến các pác coi như lễ ra mắt vậy, xin các pác cho ý kiến. Mong sau này có thể thọ giáo ở các pác nhiều hơn nữa.

chihien1984
24-04-10, 01:39 PM
chào bạn bigstream cho mình hỏi file đó mình dùng nó làm sao vậy bạn, minh đã giải nén rồi nhưng sao mà nó không mở được.

sealand
24-04-10, 02:01 PM
Đây là file viết từ tháng 8/2006. Để chạy bình thường bạn chỉnh lịch về thời gian đó.
File này code bị khoá rồi. Thực ra, file này không hợp lý là mở file ra rồi thì không có lý gì lại không bỏ Pass được. Còn bỏ Pass của Sheet các bạn tham khảo Code sau cho chủ động và đơn giản, không phải load adin khi mở Excel


Sub PasswordBreaker()

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
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

ActiveSheet.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 ActiveSheet.ProtectContents = False Then

ActiveWorkbook.Sheets(1).Select
Range(“a1”).FormulaR1C1 = 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 Sub
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next

End Sub



(Code sưu tầm trên Echip )
Cách sử dụng : Các bạn chọn Sheet bị Protect , bấm phải chuột, chọn View Code, hoặc bấm phím tắt Alt + F11
Paste đoạn code trên vào và RUN. Chờ khoảng 1-2 phút là xong. Pass đã bị phá bạn có thể nhập liệu bình thường

tungnguyen_kt
15-04-11, 12:56 PM
ban chi cu the cach lam nha ban
thanks nha

Cách sử dụng : Các bạn chọn Sheet bị Protect , bấm phải chuột, chọn View Code, hoặc bấm phím tắt Alt + F11
Paste đoạn code trên vào và RUN. Chờ khoảng 1-2 phút là xong. Pass đã bị phá bạn có thể nhập liệu bình thường

Cụ thể hơn nữa thì--> sai mất

cadafi
04-01-12, 02:17 PM
Đoạn code sau dùng để gỡ bỏ bất kỳ password protect sheet nào. Chỉ cần 1 cái chớp mắt với pass ngắn, 2 cái chớp mắt với Pass dài. Lưu ý: Mình post lên đây với mục đích học thuận và không chịu trách nhiệm với bất kỳ hậu quả nào mà người sử dụng dùng nó không đúng mục đích hoặc với mục đích đen tối! Code này mình sưu tầm trên trang của jason S, các bạn có thể search Google cũng ra.



Sub RemovePass()
' Breaks worksheet and workbook structure passwords.
Const DBLSPACE As String = vbNewLine & vbNewLine
Const AUTHORS As String = DBLSPACE & vbNewLine & "Adapted from Bob McCormick base code by" & "Jason S http://jsbi.blogspot.com"
Const HEADER As String = "AllInternalPasswords User Message"
Const VERSION As String = DBLSPACE & "Version 1.0 8 Sep 2008"
Const REPBACK As String = DBLSPACE & "Please report failure to jasonblr@gmail.com "
Const ALLCLEAR As String = DBLSPACE & "The workbook should be cleared"
Const MSGNOPWORDS1 As String = "There were no passwords on " & AUTHORS & VERSION
Const MSGNOPWORDS2 As String = "There was no protection to " & "workbook structure or windows." & DBLSPACE
Const MSGTAKETIME As String = "After pressing OK button this " & "will take some time." & DBLSPACE & "Amount of time " & "depends on how many different passwords, the "
Const MSGPWORDFOUND1 As String = "You had a Worksheet " & "Structure or Windows Password set." & DBLSPACE & "The password found was: " & DBLSPACE & "$$" & DBLSPACE & "Note it down for potential future use in other workbooks by " & "the same person who set this password." & DBLSPACE & "Now to check and clear other passwords." & AUTHORS & VERSION
Const MSGPWORDFOUND2 As String = "You had a Worksheet " & "password set." & DBLSPACE & "The password found was: " & DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & "future use in other workbooks by same person who " & "set this password." & DBLSPACE & "Now to check and clear " & "other passwords." & AUTHORS & VERSION
Const MSGONLYONE As String = "Only structure / windows " & "protected with the password that was just found." & ALLCLEAR & AUTHORS & VERSION & REPBACK
'-----------------------------------------------------------------
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
MsgBox MSGNOPWORDS1, vbInformation, HEADER
Exit Sub
End If
MsgBox MSGTAKETIME, vbInformation, HEADER
'-----------------------------------------------------------------
If Not WinTag Then
MsgBox MSGNOPWORDS2, vbInformation, HEADER
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)
MsgBox Application.Substitute(MSGPWORDFOUND1, "$$", PWord1), vbInformation, HEADER
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
MsgBox MSGONLYONE, vbInformation, HEADER
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)
MsgBox Application.Substitute(MSGPWORDFOUND2, "$$", PWord1), vbInformation, HEADER
'leverage finding Pword by trying on other sheets
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 ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
End Sub

NNT_BB
21-02-13, 11:32 AM
Ôi cám ơn bác !!! tuyệt vời hyhy em làm được rồi

phammikt
18-06-13, 08:23 AM
Em da thử như vậy rất nhiều lần nhưng không dc. anh chị có cách nào khác không. em dùng phần mền exl nhưng lại bị khóa sheep xem công thức và sửa công thức, hơn nữa lại còn mã hoá giới hạn thời gian sử dụng nữa mấy năm năy năm nào cũng phải sang để sửa lại. em muốn không phải cứ năm nào cũng sang vì đi lại rất xa. anh chị có cách nào xem giúp em dc khong

o0o0x0o0o
18-11-13, 07:12 AM
Em da thử như vậy rất nhiều lần nhưng không dc. anh chị có cách nào khác không. em dùng phần mền exl nhưng lại bị khóa sheep xem công thức và sửa công thức, hơn nữa lại còn mã hoá giới hạn thời gian sử dụng nữa mấy năm năy năm nào cũng phải sang để sửa lại. em muốn không phải cứ năm nào cũng sang vì đi lại rất xa. anh chị có cách nào xem giúp em dc khong

http://www.youtube.com/watch?v=cB_VSJKpuXs