يوليار-=بىل-=ASPساقلىۋېلىشباش بەت قىلىش
Font Qachilashكەڭ ھالەت

ئىنتىل تورى

 پارول قايتۇرىۋېلىش
 تىزىملىتىش
ئىزدەش
ئاۋات ئىزدەش: مۇسابىقەchromeexcelwordps
ئىنتىل تورى › سەينا › Office بىلىمى › Office VBA › جەدۋەل مەخپى نۇمىرىنى كورسى ...
تىزىملىككە قايتىش تېما يوللاش
كۆرۈش: 494|ئىنكاس: 1

جەدۋەل مەخپى نۇمىرىنى كورسىتىپ بىرش كودى [ئۇلانما كۆچۈرۈش]

artuq [ئىشەنچلىك ئەزا]  实名认证 

Rank: 7Rank: 7Rank: 7

تۆھپە
417
تىللا
659
شۆھرەت
845

شەرەپ تۆھپە

يوللىغان ۋاقتى 2011-6-30 18:57:21 |ھەممە قەۋەتنى كۆرۈش
تۇۋەندىكىسى مەخپى نۇمۇر سېلىنغان جەدىۋەلنىڭ  مەخپى نۇمىرىنى كورسىتىپ بىرىدۇھەمدە يىشىيپ بىرىدۇ .
  1. Option Explicit

  3. Public Sub AllInternalPasswords()
  4. ' Breaks worksheet and workbook structure passwords. Bob McCormick
  5. ' probably originator of base code algorithm modified for coverage
  6. ' of workbook structure / windows passwords and for multiple passwords
  7. '
  8. ' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1)
  9. ' Modified 2003-Apr-04 by JEM: All msgs to constants, and
  10. ' eliminate one Exit Sub (Version 1.1.1)
  11. ' Reveals hashed passwords NOT original passwords
  12. Const DBLSPACE As String = vbNewLine & vbNewLine
  13. Const AUTHORS As String = DBLSPACE & vbNewLine & _
  14. "Adapted from Bob McCormick base code by" & _
  15. "Norman Harker and JE McGimpsey"
  16. Const HEADER As String = "AllInternalPasswords User Message"
  17. Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"
  18. Const REPBACK As String = DBLSPACE & "Please report failure " & _
  19. "to the microsoft.public.excel.programming newsgroup."
  20. Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _
  21. "now be free of all password protection, so make sure you:" & _
  22. DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _
  23. DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _
  24. DBLSPACE & "Also, remember that the password was " & _
  25. "put there for a reason. Don't stuff up crucial formulas " & _
  26. "or data." & DBLSPACE & "Access and use of some data " & _
  27. "may be an offense. If in doubt, don't."
  28. Const MSGNOPWORDS1 As String = "There were no passwords on " & _
  29. "sheets, or workbook structure or windows." & AUTHORS & VERSION
  30. Const MSGNOPWORDS2 As String = "There was no protection to " & _
  31. "workbook structure or windows." & DBLSPACE & _
  32. "Proceeding to unprotect sheets." & AUTHORS & VERSION
  33. Const MSGTAKETIME As String = "After pressing OK button this " & _
  34. "will take some time." & DBLSPACE & "Amount of time " & _
  35. "depends on how many different passwords, the " & _
  36. "passwords, and your computer's specification." & DBLSPACE & _
  37. "Just be patient! Make me a coffee!" & AUTHORS & VERSION
  38. Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _
  39. "Structure or Windows Password set." & DBLSPACE & _
  40. "The password found was: " & DBLSPACE & "$$" & DBLSPACE & _
  41. "Note it down for potential future use in other workbooks by " & _
  42. "the same person who set this password." & DBLSPACE & _
  43. "Now to check and clear other passwords." & AUTHORS & VERSION
  44. Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _
  45. "password set." & DBLSPACE & "The password found was: " & _
  46. DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & _
  47. "future use in other workbooks by same person who " & _
  48. "set this password." & DBLSPACE & "Now to check and clear " & _
  49. "other passwords." & AUTHORS & VERSION
  50. Const MSGONLYONE As String = "Only structure / windows " & _
  51. "protected with the password that was just found." & _
  52. ALLCLEAR & AUTHORS & VERSION & REPBACK
  53. Dim w1 As Worksheet, w2 As Worksheet
  54. Dim i As Integer, j As Integer, k As Integer, l As Integer
  55. Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
  56. Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
  57. Dim PWord1 As String
  58. Dim ShTag As Boolean, WinTag As Boolean

  60. Application.ScreenUpdating = False
  61. With ActiveWorkbook
  62. WinTag = .ProtectStructure Or .ProtectWindows
  63. End With
  64. ShTag = False
  65. For Each w1 In Worksheets
  66. ShTag = ShTag Or w1.ProtectContents
  67. Next w1
  68. If Not ShTag And Not WinTag Then
  69. MsgBox MSGNOPWORDS1, vbInformation, HEADER
  70. Exit Sub
  71. End If
  72. MsgBox MSGTAKETIME, vbInformation, HEADER
  73. If Not WinTag Then
  74. MsgBox MSGNOPWORDS2, vbInformation, HEADER
  75. Else
  76. On Error Resume Next
  77. Do 'dummy do loop
  78. For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
  79. For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
  80. For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
  81. For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
  82. With ActiveWorkbook
  83. .Unprotect Chr(i) & Chr(j) & Chr(k) & _
  84. Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
  85. Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
  86. If .ProtectStructure = False And _
  87. .ProtectWindows = False Then
  88. PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
  89. Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
  90. Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
  91. MsgBox Application.Substitute(MSGPWORDFOUND1, _
  92. "$$", PWord1), vbInformation, HEADER
  93. Exit Do 'Bypass all for...nexts
  94. End If
  95. End With
  96. Next: Next: Next: Next: Next: Next
  97. Next: Next: Next: Next: Next: Next
  98. Loop Until True
  99. On Error GoTo 0
  100. End If
  101. If WinTag And Not ShTag Then
  102. MsgBox MSGONLYONE, vbInformation, HEADER
  103. Exit Sub
  104. End If
  105. On Error Resume Next
  106. For Each w1 In Worksheets
  107. 'Attempt clearance with PWord1
  108. w1.Unprotect PWord1
  109. Next w1
  110. On Error GoTo 0
  111. ShTag = False
  112. For Each w1 In Worksheets
  113. 'Checks for all clear ShTag triggered to 1 if not.
  114. ShTag = ShTag Or w1.ProtectContents
  115. Next w1
  116. If ShTag Then
  117. For Each w1 In Worksheets
  118. With w1
  119. If .ProtectContents Then
  120. On Error Resume Next
  121. Do 'Dummy do loop
  122. For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
  123. For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
  124. For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
  125. For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
  126. .Unprotect Chr(i) & Chr(j) & Chr(k) & _
  127. Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
  128. Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
  129. If Not .ProtectContents Then
  130. PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
  131. Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
  132. Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
  133. MsgBox Application.Substitute(MSGPWORDFOUND2, _
  134. "$$", PWord1), vbInformation, HEADER
  135. 'leverage finding Pword by trying on other sheets
  136. For Each w2 In Worksheets
  137. w2.Unprotect PWord1
  138. Next w2
  139. Exit Do 'Bypass all for...nexts
  140. End If
  141. Next: Next: Next: Next: Next: Next
  142. Next: Next: Next: Next: Next: Next
  143. Loop Until True
  144. On Error GoTo 0
  145. End If
  146. End With
  147. Next w1
  148. End If
  149. MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
  150. End Sub
مەزمۇننى كۆچۈرۈۋېلىش
ياردەم تېمىسى يوللاش ساۋادى

جابدۇق ئىشلىتىش پاش قىلىش

mamataili110 实名认证 

Rank: 8Rank: 8

تۆھپە
672
تىللا
1123
شۆھرەت
1402
يوللىغان ۋاقتى 2011-6-30 23:23:45 |ھەممە قەۋەتنى كۆرۈش
بۇ كودنى قانداق ئىشلىتىش ھەققىدە چۈشەنچە بېرۋەتمەمسىز ؟

جابدۇق ئىشلىتىش پاش قىلىش

تىزىملىككە قايتىش تېما يوللاش
ئالىي ئىنكاس
B Color Image Link Quote Code Smilies
كىرگەندىن كىيىن ئىنكاس يازالايسىز كىرىش | تىزىملىتىش

يانفۇن|Archiver|intil.cn ( 新ICP备11001938号 )

GMT+8, 2012-11-12 01:56 , Processed in 0.145081 second(s), 16 queries .

Powered by Discuz! X2(NurQut Team) Licensed

© 2001-2011 Comsenz Inc.

چوققىغا قايتىش