自定义密码生成器 Excel VBA 宏

Question

我需要使用 VBA Excel 创建一个具有自定义密码复杂性的密码生成器，我发现这段代码工作正常，问题是当我关闭 XLS 文件并再次打开时，宏会生成相同的密码，因此不是完全随机的发电机：

Sub Password_Click()
'
' Bruno Campanini 14-02-2007 Excel 2007
' Statistica.xls Sheet: Sheet10 Button: Password
'
' Compone NumPSW Password formate da:
' NumAlpha caratteri alfabetici
' NumNonAlpha caratteri non-alfabetici
' NumNum caratteri numerici
' definiti random.
'
Dim AlphaChar(1 To 26) As String, NumChar(1 To 10) As String
Dim NonAlphaChar(1 To 30) As String
Dim i As Integer, j As Integer, NumPSW As Integer
Dim NumAlpha As Integer, NumNum As Integer, NumNonAlpha As Integer
Dim PSW As String, PSWRandom As String, PSWColl As Collection
Dim R As Integer, RR As Integer, RRR As Integer, NumMaiuscole As Integer
Dim FinalRandom As Boolean, TargetRange As Range

' 26 caratteri Alpha (a - z)
For i = 97 To 122
AlphaChar(i - 96) = Chr(i)
Next

' 10 caratteri numerici (0 - 9)
For i = 1 To 10
NumChar(i) = i - 1
Next

' 30 caratteri non-Alpha
NonAlphaChar(1) = "\": NonAlphaChar(2) = "|": NonAlphaChar(3) = "!"
NonAlphaChar(4) = Chr(34): NonAlphaChar(5) = "%": NonAlphaChar(6) = "&"
NonAlphaChar(7) = "/": NonAlphaChar(8) = "(": NonAlphaChar(9) = ")"
NonAlphaChar(10) = "=": NonAlphaChar(11) = "?": NonAlphaChar(12) = "'"
NonAlphaChar(13) = "^": NonAlphaChar(14) = "_": NonAlphaChar(15) = "-"
NonAlphaChar(16) = ".": NonAlphaChar(17) = ":": NonAlphaChar(18) = ","
NonAlphaChar(19) = ";": NonAlphaChar(20) = "@": NonAlphaChar(21) = "#"
NonAlphaChar(22) = "*": NonAlphaChar(23) = "+": NonAlphaChar(24) = "["
NonAlphaChar(25) = "]": NonAlphaChar(26) = "[": NonAlphaChar(27) = "]"
NonAlphaChar(28) = "$": NonAlphaChar(29) = "<": NonAlphaChar(30) = ">"

' Definizioni ------------------------------------------
NumAlpha = 6 ' Numero caratteri alfabetici
NumNonAlpha = 1 ' Numero caratteri non alfabetici
NumNum = 4 ' Numero caratteri numerici
NumMaiuscole = 3 ' Numero maiuscole
FinalRandom = True ' Rimescolamento random finale
'
NumPSW = 10 ' Numero password da generare
Set TargetRange = [Sheet1!A1] ' Destinazione
' ------------------------------------------------------

If NumMaiuscole > NumAlpha Then
MsgBox "Non possono esservi " & NumMaiuscole & _
" maiuscole su " & NumAlpha & " caratteri!"
Exit Sub
End If

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For j = 1 To NumPSW
PSW = ""

' Definisce il gruppo AlphaChar
R = NumAlpha
RR = UBound(AlphaChar)
GoSub LoadCollection
For i = 1 To NumAlpha
PSW = PSW & AlphaChar(PSWColl(i))
Next

' Definisce le Maiuscole
R = NumMaiuscole
RR = R
GoSub LoadCollection
For i = 1 To NumMaiuscole
Mid(PSW, PSWColl(i), 1) = UCase(Mid(PSW, PSWColl(i), 1))
Next

' Definisce il gruppo NonAlphaChar
R = NumNonAlpha
RR = UBound(NonAlphaChar)
GoSub LoadCollection
For i = 1 To NumNonAlpha
PSW = PSW & NonAlphaChar(PSWColl(i))
Next

' Definisce il gruppo NumChar
R = NumNum
RR = UBound(NumChar)
GoSub LoadCollection
For i = 1 To NumNum
PSW = PSW & NumChar(PSWColl(i))
Next

If FinalRandom Then
' Rimescola Random i tre gruppi
R = NumAlpha + NumNonAlpha + NumNum
RR = R
GoSub LoadCollection
PSWRandom = ""
For i = 1 To NumAlpha + NumNonAlpha + NumNum
PSWRandom = PSWRandom & Mid(PSW, PSWColl(i), 1)
Next
PSW = PSWRandom
End If

TargetRange(j) = "'" & PSW
Next

Exit_Sub:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub

' Carica PSWColl con valori unici
LoadCollection:
Set PSWColl = New Collection
Do Until PSWColl.Count = R
RRR = Int((RR) * Rnd + 1)
On Error Resume Next
PSWColl.Add RRR, CStr(RRR)
On Error GoTo 0
Loop
Return

End Sub

谢谢

是否可以修改代码以便每次打开文件时生成随机密码？

谢谢

Answer 1

计算机无法生成真正的随机数。它们生成伪随机数：当您从 Excel 请求随机数时，它会根据“种子”值以看似随机的序列响应第一个数字。

后续请求只需回忆该序列中的下一个数字。Excel 重置后，它会再次返回到第一个数字，并且行为与之前完全相同。这就是你所经历的。

不过，可以使用以下命令沿着数字序列移动 - 所谓的“更改种子” Randomize(seed_value)：

Randomize(50) 'sets the seed to 50

产生看起来更随机的种子的一种方法是使用一个不太可能与上次调用时相同的值。一些独立于代码本身的东西。最简单的方法是使用计时器（基本上是自午夜以来的毫秒数）作为种子数。连续两次发生这样的事，也太巧了吧！

微软为我们提供了一种方便的使用方法：如果没有参数传递给 Randomize，它会使用 Timer 值作为种子值：

Randomize 'sets the seed to the timer