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

Thảo luận trong 'Ứng dụng Excel' bắt đầu bởi levanduyet, 21 Tháng mười một 2004.

6,152 lượt xem

  1. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
     
    #1
  2. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
     
    #2
  3. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
     
    #3
  4. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
    ' 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
     
    #4
  5. NO_CO

    NO_CO Guest

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

Chia sẻ trang này