Вручную силу пароля VBA

Question

Я пытаюсь тренироваться, как можно перебирать все возможности строки, но я, кажется, не очень хорошо.

Я до сих пор помещал набор символов в массив, но я не могу, чтобы жизнь меня обнимала меня, как я могу заставить его работать. У меня это так далеко, но мой мозг не может обойти его.

Может ли кто-нибудь пролить свет на правильный способ сделать это и, возможно, псевдокод, чтобы я мог создать свой собственный.

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 

EDIT :::

Я отредактировал мой код, но этот путь я должен знать длину и что не создает эффективный алгоритм? Любая помощь?

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 

Answer 1

Я думаю, что это то, что вы хотите:

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 

Answer 2

К сожалению, для меня эта проблема застрял в моей голове, пока я не должен был записать свое решение. Решение @ 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): ':;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ' 
1: 00000 
2: 00001 
3: 00002 
4: 00003 
... 
147008441: ZZZZX 
147008442: ZZZZY 
147008443: ZZZZZ 
Total strings generated: 147008443 

Answer 3

Я на самом деле придумал ответ мой собственный ответ. Он пришел ко мне сегодня на работу.

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 

Answer 4

Это, вероятно, может быть улучшен, но простая идея заключается в том, чтобы рассматривать символы отдельно и пролонгировать как бы одометр. BTW, я использовал однонаправленные индексы для массива, но с нулевым значением для отдельных цифр.

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 из-за переноса из десятого места (переполнение). Я сомневаюсь, что вы действительно позволите этому так долго работать.

Answer 5

Я отредактировал код в ответе JA72, чтобы предоставить более полную технику для грубой форсировки пароля «Ограничить редактирование». Я удалил порты array и ReDim и объединил их в одну суб. Проблема с JA-методом заключается в том, что она работает для набора символов ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz для 4-символьных паролей ([26 + 26 + 10]^4 = 14,776,336 возможностей), он не работает с 5-символьным паролем ([26+ 26 + 10]^5 = 916,132,832 возможности). Функции массива в исходном коде приводят к тому, что 32-разрядное приложение Office сразу же исчерпает память при попытке паролей из 5 символов или за его пределами. Я также заметил, что использование памяти скалолазало, так как оно повторялось через 14 миллионов возможностей с исходным кодом, тогда как использование памяти оставалось без изменений с кодом ниже.

Этот пример специально нацелен на метод ActiveDocument.Unprotect Word. Достаточно просто изменить раздел, который пытается использовать пароль для любой модели объекта Office, соответствующей вашим потребностям.

Этот код работал для меня через несколько часов и около 400 миллионов попыток ввода пароля. Я чувствую, что это скорее хеш-столкновение против фактического пароля, но я возьму то, что работает.

Если вы хотите видеть выходную работу, прежде чем совершать несколько часов работы процессора, для удобства есть несколько вещей. Это также объясняется в комментариях кодов.

• Задайте количество итераций, отредактировав переменную 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 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" 
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