Lỡ quên password khi Protect sheet thì sao?

[levanduyet]

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

 

[levanduyet]

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

 

[levanduyet]

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

 

[levanduyet]

Password phần IV
Function TestPassword(pwType As Integer, wb As Workbook, WBS As Object, testPWD As String, sbMsg As String) As Boolean
' pwType= 2roteced workbook, 3rotected 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
' 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

 

[NO_CO]

Cảm ơn bác Duyệt rất nhiều.