Trang 1 của 2 12 CuốiCuối
Kết quả 1 đến 10 của 16

Chủ đề: Lỡ quên password khi Protect sheet thì làm sao?

  1. #1
    cushinthang Guest

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

    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:

    Mã:
     
    ' 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)


  2. #2
    Ngày tham gia
    Aug 2015
    Bài viết
    0
    <font color="red">Password phần II
    </font>



    Mã:
    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)

  3. #3
    Ngày tham gia
    Aug 2015
    Bài viết
    0
    Password phần III
    Mã:
    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)

  4. #4
    gamevui5k Guest
    Password phần IV

    Mã:
    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

  5. #5
    TranElly Guest
    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à [IMG]images/smilies/a01.gif[/IMG]

  6. #6
    niemtin259 Guest
    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...

  7. #7
    muabui Guest
    Trích dẫn Gửi bởi workman
    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

  8. #8
    minhthu1987 Guest
    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 [IMG]images/smilies/cry.gif[/IMG]

  9. #9
    aukid411 Guest
    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.

    quần áo trẻ em | quan ao tre em | quần áo sơ sinh | quần áo bé trai | quần áo bé gái | bodysuit carter | quan ao so sinh | quan ao tre em nhap khau

  10. #10
    tuanpin174 Guest
    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.

Trang 1 của 2 12 CuốiCuối

Quyền viết bài

  • Bạn Không thể gửi Chủ đề mới
  • Bạn Không thể Gửi trả lời
  • Bạn Không thể Gửi file đính kèm
  • Bạn Không thể Sửa bài viết của mình
  •