暴力破解密码 VBA
Brute force password VBA
我正在尝试锻炼如何循环遍历字符串的所有可能性，但我似乎进展得不太顺利。
到目前为止，我已经将一组字符放入一个数组中，但我终究无法理解如何让它发挥作用。我已经说到这里了，但我的大脑似乎无法绕过它。
任何人都可以阐明执行此操作的正确方法以及可能的伪代码，以便我可以创建自己的代码。
Function passwordGenerator(length As Integer)
Dim characters() As String
Dim x As Integer
Dim y As Integer
Dim p As Integer
Dim t As Integer
Dim oldpassword As String
Dim newcharacter As String
ReDim Preserve characters(1)
For x = 48 To 90
ReDim Preserve characters(UBound(characters) + 1)
characters(UBound(characters) - 1) = VBA.Chr(x)
Next x
y = 1
Do
For x = 1 To length
oldpassword = generateBlank(x)
p = 1
For t = 1 To p
newpassword = WorksheetFunction.Replace(oldpassword, t, 1, characters(y))
For y = 1 To UBound(characters)
newpassword = WorksheetFunction.Replace(oldpassword, p, 1, characters(y))
Debug.Print newpassword
p = p + 1
Next y
Next t
Next x
Loop
End Function
Function generateBlank(length As Integer)
Dim x As Integer
For x = 1 To length
generateBlank = generateBlank & "A"
Next x
End Function
编辑:::
我已经编辑了我的代码，但是这样我就必须知道长度，这不会创建一个有效的算法吗？有帮助吗？
Function passwordGenerator()
Dim characters() As String
Dim x As Integer
Dim y As Integer
Dim p As Integer
Dim t As Integer
Dim w As Integer
Dim e As Integer
Dim r As Integer
Dim u As Integer
Dim oldpassword As String
Dim newcharacter As String
ReDim Preserve characters(1)
For x = 48 To 90
ReDim Preserve characters(UBound(characters) + 1)
characters(UBound(characters) - 1) = VBA.Chr(x)
Next x
y = 1
oldpassword = generateBlank(3)
For x = 1 To UBound(characters)
oldpassword = WorksheetFunction.Replace(oldpassword, 1, 1, characters(x))
For t = 1 To UBound(characters)
oldpassword = WorksheetFunction.Replace(oldpassword, 2, 1, characters(t))
For y = 1 To UBound(characters)
oldpassword = WorksheetFunction.Replace(oldpassword, 3, 1, characters(y))
For q = 1 To UBound(characters)
oldpassword = WorksheetFunction.Replace(oldpassword, 4, 1, characters(q))
For w = 1 To UBound(characters)
oldpassword = WorksheetFunction.Replace(oldpassword, 5, 1, characters(w))
Debug.Print oldpassword
DoEvents
Next w
Next q
Next y
Next t
Next x
End Function
我想这就是你想要的：
Public Function GeneratePassword(ByVal index As Long, ByVal pw_len As Byte, ByRef characters As String) As String
' Convert string 'characters' into array of characters in 'dict'
Dim s As Integer, n As Integer
n = Len(characters)
Dim pw As String
pw = vbNullString
Dim j As Long, base As Long
base = n
For s = 1 To pw_len
j = ((index - 1) Mod n) + 1
pw = Mid(characters, j, 1) & pw
index = (index - j) \ n + 1
Next s
GeneratePassword = pw
End Function
Public Sub TestPwGen()
Dim i As Long, pw() As String, abc As String
abc = "ABC"
Dim n As Integer, l As Integer, m As Long
' password length 4, generate 18 passwords
l = 4: m = Len(abc) ^ l
n = 18
ReDim pw(1 To n)
For i = 1 To n 'Total is m
pw(i) = GeneratePassword(i, l, abc)
Debug.Print pw(i)
Next i
End Sub
结果：
AAAA
AAAB
AAAC
AABA
AABB
AABC
AACA
AACB
AACC
ABAA
ABAB
ABAC
ABBA
ABBB
ABBC
ABCA
ABCB
ABCC
不幸的是，这个问题一直困扰着我，直到我不得不写下我的解决方案。我认为 @ja72 的解决方案更优雅，但我会列出我的解决方案，以便提供另一种方法。
Option Explicit
Function passwordGenerator()
Dim characters() As String
Dim loASCII As Integer
Dim hiASCII As Integer
Dim numASCII As Integer
Dim i As Integer
loASCII = 48
hiASCII = 90
numASCII = hiASCII - loASCII
ReDim characters(numASCII)
For i = loASCII To hiASCII
characters(i - loASCII) = VBA.Chr(i)
Next i
PermutationsOn characters, 2
End Function
Sub PermutationsOn(ByRef charSet() As String, numPlaces As Integer)
'--- Generates every possible combination of characters from the given
' character set for an n-place string
' Inputs: charSet - string array of all possible values
' numPlaces - integer noting how many characters in the output string
Dim chars() As String
Dim thisString As String
Dim i As Integer
Dim t As Long
Dim numInCharSet As Integer
Dim start As Integer
Dim placevalues() As Integer
'--- this array is used as a set of indexes into the character set, the
' indexes will range from charSet(0) to charSet(last), "counting" as
' in a base-n number, where n = len(charSet)+1
ReDim placevalues(1 To numPlaces) As Integer
ReDim chars(1 To numPlaces)
start = LBound(charSet)
numInCharSet = UBound(charSet)
'--- initialize the arrays
For i = 1 To numPlaces
placevalues(i) = 0
Next i
For i = 1 To numPlaces
chars(i) = charSet(start)
Next i
Debug.Print "Permutations on a " & numPlaces & "-place value from a character set"
Debug.Print "Character set (len=" & numInCharSet + 1 & "): '" & ConcatToString(charSet) & "'"
'--- build the first string...
t = 1
thisString = BuildStringFromSet(placevalues, charSet)
Debug.Print t & ": " & thisString
Do Until IncrementValues(placevalues, charSet)
'--- build the current string...
thisString = BuildStringFromSet(placevalues, charSet)
t = t + 1
Debug.Print t & ": " & thisString
Loop
Debug.Print "Total strings generated: " & t
End Sub
Function IncrementValues(ByRef placevalues() As Integer, ByRef placeRange() As String) As Boolean
'--- views the placeValues array as a "single" number with a numeric base of "numInRange+1"
Dim highestValueReached As Boolean
Dim numPlaces As Integer
Dim numInRange As Integer
Dim i As Integer
numPlaces = UBound(placevalues)
numInRange = UBound(placeRange)
highestValueReached = False
For i = 1 To numPlaces
If placevalues(i) <> numInRange Then
placevalues(i) = placevalues(i) + 1
Exit For
Else
If i = numPlaces Then
highestValueReached = True
Exit For
Else
placevalues(i) = 0
End If
End If
Next i
IncrementValues = highestValueReached
End Function
Function BuildStringFromSet(ByRef placevalues() As Integer, ByRef charSet() As String) As String
Dim i As Integer
Dim finalString As String
finalString = ""
For i = UBound(placevalues) To 1 Step -1
finalString = finalString & charSet(placevalues(i))
Next i
BuildStringFromSet = finalString
End Function
Function ConcatToString(chars() As String) As String
Dim finalString As String
Dim j As Integer
finalString = ""
For j = LBound(chars) To UBound(chars)
finalString = finalString & chars(j)
Next j
ConcatToString = finalString
End Function
与输出结果：
Permutations on a 5-place value from a character set
Character set (len=43): '0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ'
1: 00000
2: 00001
3: 00002
4: 00003
...
147008441: ZZZZX
147008442: ZZZZY
147008443: ZZZZZ
Total strings generated: 147008443
其实我自己想出了一个答案。今天上班遇到的。
Public characters() As String
Public oldpassword As String
Function passwordGenerator1(maxLength)
Dim x As Integer, newcharacter As String
ReDim Preserve characters(1)
'set characters in array
For x = 48 To 90
ReDim Preserve characters(UBound(characters) + 1)
characters(UBound(characters) - 1) = VBA.Chr(x)
Next x
'loop through all lengths
For x = 1 To maxLength
oldpassword = generateBlank(x)
changeCharacter 1, x
Next x
End Function
-
Function changeCharacter(characterPos, length As Integer)
For x = 1 To UBound(characters)
If characterPos <> length Then changeCharacter characterPos + 1, length
oldpassword = WorksheetFunction.Replace(oldpassword, characterPos, 1, characters(x))
Debug.Print oldpassword
DoEvents
Next x
End Function
-
Function generateBlank(length As Integer)
Dim x As Integer
For x = 1 To length
generateBlank = generateBlank & "A"
Next x
End Function
这可能会得到改进，但一个简单的想法是分别对待角色并像里程表一样翻转。顺便说一句，我为数组使用了基于一的索引，但为单个数字使用了基于零的索引。
Public Sub PasswordGen()
Const MaxDigit = 42
Const MaxLoops = MaxDigit * MaxDigit * MaxDigit * MaxDigit * MaxDigit
Dim places(10) As Integer
Dim counter As Integer
Dim digit As Integer
Dim password As String
counter = 0
Do While counter < MaxLoops
password = Chr(places(5) + 48) & Chr(places(4) + 48) & Chr(places(3) + 48) & Chr(places(2) + 48) & Chr(places(5) + 48)
'Debug.Print password
counter = counter + 1
digit = 1
Do While digit < 10
places(digit) = places(digit) + 1
If places(digit) = MaxDigit Then
places(digit) = 0
digit = digit + 1
Else
Exit Do
End If
Loop
Loop
End Sub
您也可以取消计数器，并在数字等于 11 时退出循环，因为第十位的进位（溢出）。我怀疑你真的会 运行 这么久。
我编辑了 JA72 的答案中的代码，以提供更全面的暴力破解 "Restrict Editing" 密码的技术。我删除了 array 和 ReDim 部分，并将它们全部合并为一个子。 JA 方法的问题是，虽然它适用于 ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789 字符集的 4 字符密码（[26+26+10]^4 = 14,776,336 种可能性），但它不适用于 5 字符密码（[26+26+10]^5 = 916,132,832 种可能性）。原始代码中的数组函数会导致 32 位 Office 应用程序在尝试 5 个或更多字符的密码时立即 运行 内存不足。我还注意到内存使用量攀升，因为它使用原始代码迭代了 1400 万种可能性，而内存使用量与下面的代码持平。
此示例专门针对 Word 的 ActiveDocument.Unprotect 方法。将尝试使用密码的部分更改为适合您需要的任何 Office 对象模型非常简单。
经过几个小时和大约 4 亿次密码尝试后，此代码对我有效。我觉得这可能是哈希与实际密码的冲突，但我会采取有效的方法。
如果您想在投入几个小时 CPU 之前查看输出结果，为方便起见，这里包含一些内容。这也在代码注释中进行了解释。
- 通过编辑
n 变量设置迭代次数。
- 将第一个循环
For i = 1 to m 更改为 For i = 1 to n 以仅循环这么多次而不是所有可能的循环。
- 通过取消注释
If i Mod showEvery = 0 Then Debug.Print i, pw 行来打开输出。
- 如果要查看每个密码：将
showEvery 设置为 1，否则选择不同的数字以查看第 n 个密码。
- 评论实际尝试输入密码的部分
ActiveDocument.Unprotect 并检查错误。它在代码中用注释标记。
Sub GetPassword()
Dim s As Integer, totalChars As Integer, j As Long 'GeneratePassword loop vars
Dim gpi As Long 'GeneratePassword index
Dim characters As String 'characters that can be part of the password.
Dim pw As String 'password attempt string
characters = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
totalChars = Len(characters)
Dim i As Double 'count integer
Dim n As Double 'number of interations to complete (if active)
Dim pwLen As Integer 'length of password
Dim m As Double 'number of permutations
Dim showEvery As Integer 'show multiples of this in debug log
pwLen = 5 'password length
m = totalChars ^ pwLen 'number of potential combinations of characters for the length
n = 1000 'number of loop iterations if you don't want all of them.
showEvery = 1 'use 1 here to show every password. 10000 shows every 10,000th password, etc...
On Error Resume Next 'no need to invoke an error handler, just check the Err.Number
For i = 1 To m 'use "1 to n" if you want to test a certain number or "1 to m" if you want try all combinations.
pw = vbNullString
gpi = i 'assign GeneratePassword loop integer our loop integer
'GeneratePassword loop
For s = 1 To pwLen
j = ((gpi - 1) Mod totalChars) + 1
pw = Mid(characters, j, 1) & pw
gpi = (gpi - j) \ totalChars + 1
Next s
'writes out if uncommented and it's the right i. comment out once you're sure of the output.
'If i Mod showEvery = 0 Then Debug.Print i, pw
'try the password to unprotect the document, comment if just testing passwords in Immediate window
ActiveDocument.Unprotect password:=pw
If Err.Number <> 5485 Then
MsgBox "Unexpected Error Code: " & Err.Number & vbCrLf & Err.Description & vbCrLf & pw
End If
If ActiveDocument.ProtectionType = wdNoProtection Then
MsgBox "Unprotected with password: " & vbCrLf & pw
Debug.Print "Unprotect Password: " & pw
Exit Sub
End If
'end trying the password.
Next i
End Sub
我正在尝试锻炼如何循环遍历字符串的所有可能性，但我似乎进展得不太顺利。
到目前为止，我已经将一组字符放入一个数组中，但我终究无法理解如何让它发挥作用。我已经说到这里了，但我的大脑似乎无法绕过它。
任何人都可以阐明执行此操作的正确方法以及可能的伪代码，以便我可以创建自己的代码。
Function passwordGenerator(length As Integer)
Dim characters() As String
Dim x As Integer
Dim y As Integer
Dim p As Integer
Dim t As Integer
Dim oldpassword As String
Dim newcharacter As String
ReDim Preserve characters(1)
For x = 48 To 90
ReDim Preserve characters(UBound(characters) + 1)
characters(UBound(characters) - 1) = VBA.Chr(x)
Next x
y = 1
Do
For x = 1 To length
oldpassword = generateBlank(x)
p = 1
For t = 1 To p
newpassword = WorksheetFunction.Replace(oldpassword, t, 1, characters(y))
For y = 1 To UBound(characters)
newpassword = WorksheetFunction.Replace(oldpassword, p, 1, characters(y))
Debug.Print newpassword
p = p + 1
Next y
Next t
Next x
Loop
End Function
Function generateBlank(length As Integer)
Dim x As Integer
For x = 1 To length
generateBlank = generateBlank & "A"
Next x
End Function
编辑:::
我已经编辑了我的代码，但是这样我就必须知道长度，这不会创建一个有效的算法吗？有帮助吗？
Function passwordGenerator()
Dim characters() As String
Dim x As Integer
Dim y As Integer
Dim p As Integer
Dim t As Integer
Dim w As Integer
Dim e As Integer
Dim r As Integer
Dim u As Integer
Dim oldpassword As String
Dim newcharacter As String
ReDim Preserve characters(1)
For x = 48 To 90
ReDim Preserve characters(UBound(characters) + 1)
characters(UBound(characters) - 1) = VBA.Chr(x)
Next x
y = 1
oldpassword = generateBlank(3)
For x = 1 To UBound(characters)
oldpassword = WorksheetFunction.Replace(oldpassword, 1, 1, characters(x))
For t = 1 To UBound(characters)
oldpassword = WorksheetFunction.Replace(oldpassword, 2, 1, characters(t))
For y = 1 To UBound(characters)
oldpassword = WorksheetFunction.Replace(oldpassword, 3, 1, characters(y))
For q = 1 To UBound(characters)
oldpassword = WorksheetFunction.Replace(oldpassword, 4, 1, characters(q))
For w = 1 To UBound(characters)
oldpassword = WorksheetFunction.Replace(oldpassword, 5, 1, characters(w))
Debug.Print oldpassword
DoEvents
Next w
Next q
Next y
Next t
Next x
End Function
我想这就是你想要的：
Public Function GeneratePassword(ByVal index As Long, ByVal pw_len As Byte, ByRef characters As String) As String
' Convert string 'characters' into array of characters in 'dict'
Dim s As Integer, n As Integer
n = Len(characters)
Dim pw As String
pw = vbNullString
Dim j As Long, base As Long
base = n
For s = 1 To pw_len
j = ((index - 1) Mod n) + 1
pw = Mid(characters, j, 1) & pw
index = (index - j) \ n + 1
Next s
GeneratePassword = pw
End Function
Public Sub TestPwGen()
Dim i As Long, pw() As String, abc As String
abc = "ABC"
Dim n As Integer, l As Integer, m As Long
' password length 4, generate 18 passwords
l = 4: m = Len(abc) ^ l
n = 18
ReDim pw(1 To n)
For i = 1 To n 'Total is m
pw(i) = GeneratePassword(i, l, abc)
Debug.Print pw(i)
Next i
End Sub
结果：
AAAA
AAAB
AAAC
AABA
AABB
AABC
AACA
AACB
AACC
ABAA
ABAB
ABAC
ABBA
ABBB
ABBC
ABCA
ABCB
ABCC
不幸的是，这个问题一直困扰着我，直到我不得不写下我的解决方案。我认为 @ja72 的解决方案更优雅，但我会列出我的解决方案，以便提供另一种方法。
Option Explicit
Function passwordGenerator()
Dim characters() As String
Dim loASCII As Integer
Dim hiASCII As Integer
Dim numASCII As Integer
Dim i As Integer
loASCII = 48
hiASCII = 90
numASCII = hiASCII - loASCII
ReDim characters(numASCII)
For i = loASCII To hiASCII
characters(i - loASCII) = VBA.Chr(i)
Next i
PermutationsOn characters, 2
End Function
Sub PermutationsOn(ByRef charSet() As String, numPlaces As Integer)
'--- Generates every possible combination of characters from the given
' character set for an n-place string
' Inputs: charSet - string array of all possible values
' numPlaces - integer noting how many characters in the output string
Dim chars() As String
Dim thisString As String
Dim i As Integer
Dim t As Long
Dim numInCharSet As Integer
Dim start As Integer
Dim placevalues() As Integer
'--- this array is used as a set of indexes into the character set, the
' indexes will range from charSet(0) to charSet(last), "counting" as
' in a base-n number, where n = len(charSet)+1
ReDim placevalues(1 To numPlaces) As Integer
ReDim chars(1 To numPlaces)
start = LBound(charSet)
numInCharSet = UBound(charSet)
'--- initialize the arrays
For i = 1 To numPlaces
placevalues(i) = 0
Next i
For i = 1 To numPlaces
chars(i) = charSet(start)
Next i
Debug.Print "Permutations on a " & numPlaces & "-place value from a character set"
Debug.Print "Character set (len=" & numInCharSet + 1 & "): '" & ConcatToString(charSet) & "'"
'--- build the first string...
t = 1
thisString = BuildStringFromSet(placevalues, charSet)
Debug.Print t & ": " & thisString
Do Until IncrementValues(placevalues, charSet)
'--- build the current string...
thisString = BuildStringFromSet(placevalues, charSet)
t = t + 1
Debug.Print t & ": " & thisString
Loop
Debug.Print "Total strings generated: " & t
End Sub
Function IncrementValues(ByRef placevalues() As Integer, ByRef placeRange() As String) As Boolean
'--- views the placeValues array as a "single" number with a numeric base of "numInRange+1"
Dim highestValueReached As Boolean
Dim numPlaces As Integer
Dim numInRange As Integer
Dim i As Integer
numPlaces = UBound(placevalues)
numInRange = UBound(placeRange)
highestValueReached = False
For i = 1 To numPlaces
If placevalues(i) <> numInRange Then
placevalues(i) = placevalues(i) + 1
Exit For
Else
If i = numPlaces Then
highestValueReached = True
Exit For
Else
placevalues(i) = 0
End If
End If
Next i
IncrementValues = highestValueReached
End Function
Function BuildStringFromSet(ByRef placevalues() As Integer, ByRef charSet() As String) As String
Dim i As Integer
Dim finalString As String
finalString = ""
For i = UBound(placevalues) To 1 Step -1
finalString = finalString & charSet(placevalues(i))
Next i
BuildStringFromSet = finalString
End Function
Function ConcatToString(chars() As String) As String
Dim finalString As String
Dim j As Integer
finalString = ""
For j = LBound(chars) To UBound(chars)
finalString = finalString & chars(j)
Next j
ConcatToString = finalString
End Function
与输出结果：
Permutations on a 5-place value from a character set
Character set (len=43): '0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ'
1: 00000
2: 00001
3: 00002
4: 00003
...
147008441: ZZZZX
147008442: ZZZZY
147008443: ZZZZZ
Total strings generated: 147008443
其实我自己想出了一个答案。今天上班遇到的。
Public characters() As String
Public oldpassword As String
Function passwordGenerator1(maxLength)
Dim x As Integer, newcharacter As String
ReDim Preserve characters(1)
'set characters in array
For x = 48 To 90
ReDim Preserve characters(UBound(characters) + 1)
characters(UBound(characters) - 1) = VBA.Chr(x)
Next x
'loop through all lengths
For x = 1 To maxLength
oldpassword = generateBlank(x)
changeCharacter 1, x
Next x
End Function
-
Function changeCharacter(characterPos, length As Integer)
For x = 1 To UBound(characters)
If characterPos <> length Then changeCharacter characterPos + 1, length
oldpassword = WorksheetFunction.Replace(oldpassword, characterPos, 1, characters(x))
Debug.Print oldpassword
DoEvents
Next x
End Function
-
Function generateBlank(length As Integer)
Dim x As Integer
For x = 1 To length
generateBlank = generateBlank & "A"
Next x
End Function
这可能会得到改进，但一个简单的想法是分别对待角色并像里程表一样翻转。顺便说一句，我为数组使用了基于一的索引，但为单个数字使用了基于零的索引。
Public Sub PasswordGen()
Const MaxDigit = 42
Const MaxLoops = MaxDigit * MaxDigit * MaxDigit * MaxDigit * MaxDigit
Dim places(10) As Integer
Dim counter As Integer
Dim digit As Integer
Dim password As String
counter = 0
Do While counter < MaxLoops
password = Chr(places(5) + 48) & Chr(places(4) + 48) & Chr(places(3) + 48) & Chr(places(2) + 48) & Chr(places(5) + 48)
'Debug.Print password
counter = counter + 1
digit = 1
Do While digit < 10
places(digit) = places(digit) + 1
If places(digit) = MaxDigit Then
places(digit) = 0
digit = digit + 1
Else
Exit Do
End If
Loop
Loop
End Sub
您也可以取消计数器，并在数字等于 11 时退出循环，因为第十位的进位（溢出）。我怀疑你真的会 运行 这么久。
我编辑了 JA72 的答案中的代码，以提供更全面的暴力破解 "Restrict Editing" 密码的技术。我删除了 array 和 ReDim 部分，并将它们全部合并为一个子。 JA 方法的问题是，虽然它适用于 ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789 字符集的 4 字符密码（[26+26+10]^4 = 14,776,336 种可能性），但它不适用于 5 字符密码（[26+26+10]^5 = 916,132,832 种可能性）。原始代码中的数组函数会导致 32 位 Office 应用程序在尝试 5 个或更多字符的密码时立即 运行 内存不足。我还注意到内存使用量攀升，因为它使用原始代码迭代了 1400 万种可能性，而内存使用量与下面的代码持平。
此示例专门针对 Word 的 ActiveDocument.Unprotect 方法。将尝试使用密码的部分更改为适合您需要的任何 Office 对象模型非常简单。
经过几个小时和大约 4 亿次密码尝试后，此代码对我有效。我觉得这可能是哈希与实际密码的冲突，但我会采取有效的方法。
如果您想在投入几个小时 CPU 之前查看输出结果，为方便起见，这里包含一些内容。这也在代码注释中进行了解释。
- 通过编辑
n变量设置迭代次数。 - 将第一个循环
For i = 1 to m更改为For i = 1 to n以仅循环这么多次而不是所有可能的循环。 - 通过取消注释
If i Mod showEvery = 0 Then Debug.Print i, pw行来打开输出。 - 如果要查看每个密码：将
showEvery设置为 1，否则选择不同的数字以查看第 n 个密码。 - 评论实际尝试输入密码的部分
ActiveDocument.Unprotect并检查错误。它在代码中用注释标记。
Sub GetPassword()
Dim s As Integer, totalChars As Integer, j As Long 'GeneratePassword loop vars
Dim gpi As Long 'GeneratePassword index
Dim characters As String 'characters that can be part of the password.
Dim pw As String 'password attempt string
characters = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
totalChars = Len(characters)
Dim i As Double 'count integer
Dim n As Double 'number of interations to complete (if active)
Dim pwLen As Integer 'length of password
Dim m As Double 'number of permutations
Dim showEvery As Integer 'show multiples of this in debug log
pwLen = 5 'password length
m = totalChars ^ pwLen 'number of potential combinations of characters for the length
n = 1000 'number of loop iterations if you don't want all of them.
showEvery = 1 'use 1 here to show every password. 10000 shows every 10,000th password, etc...
On Error Resume Next 'no need to invoke an error handler, just check the Err.Number
For i = 1 To m 'use "1 to n" if you want to test a certain number or "1 to m" if you want try all combinations.
pw = vbNullString
gpi = i 'assign GeneratePassword loop integer our loop integer
'GeneratePassword loop
For s = 1 To pwLen
j = ((gpi - 1) Mod totalChars) + 1
pw = Mid(characters, j, 1) & pw
gpi = (gpi - j) \ totalChars + 1
Next s
'writes out if uncommented and it's the right i. comment out once you're sure of the output.
'If i Mod showEvery = 0 Then Debug.Print i, pw
'try the password to unprotect the document, comment if just testing passwords in Immediate window
ActiveDocument.Unprotect password:=pw
If Err.Number <> 5485 Then
MsgBox "Unexpected Error Code: " & Err.Number & vbCrLf & Err.Description & vbCrLf & pw
End If
If ActiveDocument.ProtectionType = wdNoProtection Then
MsgBox "Unprotected with password: " & vbCrLf & pw
Debug.Print "Unprotect Password: " & pw
Exit Sub
End If
'end trying the password.
Next i
End Sub