I need to create a password generator with VBA Excel with custom complexity of the passwords, I found this code that works fine, the problem is that when I close the XLS file and open again the macro generate the same passwords so is not a full random generator:
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
Thanks
Is possible to modify the code in order to generate random password every time I open the files ?
Thanks
Randomizebefore the lineRRR = Int((RR) * Rnd + 1)...<,>,|,^or ` \` can be problematic. They are used for example to escape characters or redirect input or output.^is also difficult to use, it requires two key strokes (on a Swiss keyboard)