Génération de chaîne de caractères aléatoires
par
, 27/09/2018 à 12h15 (565 Affichages)
___________________________________________________________________________________
Bonjour,
On peut, pour x raisons (obfuscation de code, génération de mots de passe, etc...), avoir besoin de générer des chaines de caractères complexes ET aléatoires.
Je vous donne deux fonctions qui le font, pour vous...
La première : GenerateStringAlea comporte deux arguments :
- n As Long : la longueur de la chaîne voulue (minimum 4 caractères),
- e As Boolean : si True, évite la suite de 2 caractères similaires visuellement (exemple O0)
Dans cette fonction vous ne pouvez pas choisir le nombre de lettres Majuscules, minuscules, le nombre de chiffres ni de caractères spéciaux.
Code vba : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45 Public Function GenerateStringAlea(n As Long, e As Boolean) As String 'create 1 String without pattern (just with the String's lenght and similar visually) Dim t As String, i As Long, j As Long, A As Boolean, b As Boolean, C As Boolean, d As Boolean Randomize Timer If n < 4 Then GenerateStringAlea = "Error. Numbers of characters is too small. Min : 4" ElseIf n >= 4 And n < 7 Then t = Alea_Caract$(122, 97) & Alea_Caract$(90, 65) & Alea_Caract$(57, 48) & Alea_Car_Spec$ For j = 5 To n i = Int((4 * Rnd) + 1) Select Case i Case 1: t = t & Alea_Caract$(122, 97) Case 2: t = t & Alea_Caract$(90, 65) Case 3: t = t & Alea_Caract$(57, 48) Case 4: t = t & Alea_Car_Spec$ End Select Next j GenerateStringAlea = Shuffle_Letters(t) Else Do i = Int((4 * Rnd) + 1) Select Case i Case 1: t = t & Alea_Caract$(122, 97): A = True Case 2: t = t & Alea_Caract$(90, 65): b = True Case 3: t = t & Alea_Caract$(57, 48): C = True Case 4: t = t & Alea_Car_Spec$: d = True End Select If Len(t) >= 2 And e Then If Similar_Characters(t) Then t = Left$(t, Len(t) - 1) End If If Len(t) = n Then If A And b And C And d Then Exit Do Else Efface t, A, b, C, d GenerateStringAlea = GenerateStringAlea(n, e) End If ElseIf Len(t) > n Then Efface t, A, b, C, d GenerateStringAlea = GenerateStringAlea(n, e) End If Loop GenerateStringAlea = Shuffle_Letters(t) End If End Function
La seconde : GenerateStringAleaPattern comporte également deux arguments :
- s As String : le "pattern" souhaité (cf exemple ci-dessous),
- e As Boolean : si True, évite la suite de 2 caractères similaires visuellement (exemple O0)
Exemple de Pattern : "A/9-a/1-9/4-!/5"
Les caractères rouge et gras ci-dessus ne sont pas obligatoires, mais il faut conserver les mêmes séparateurs : / et - ET ne pas remplacer A, a, 9 ou ! par d'autres caractères.
La signification :
- A/9 := 9 majuscules
- a/1 := 1 minuscule
- 9/4 := 4 chiffres
- !/5 := 5 caractères spéciaux
Autres patterns possibles, sans chiffres : "A/5-a/2-!/3" ou encore sans caractères minuscules : "A/8-9/5-!/3", etc. tout est envisageable... ("A/19" vous fournira une chaîne de 19 majuscules)
Code vba : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46 Public Function GenerateStringAleaPattern(s As String, e As Boolean) As String 'create 1 String with pattern Dim A, i As Long, j As Long, st As String, Nb As Long A = Split(s, "-") For i = 0 To UBound(A) Select Case Left$(A(i), 1) Case "A" Nb = CLng(Split(A(i), "/")(1)): j = 0 Do j = j + 1 st = st & Alea_Caract$(90, 65) If Len(st) >= 2 And e Then If Similar_Characters(st) Then st = Left$(st, Len(st) - 1): j = j - 1 End If Loop While j < Nb Case "a" Nb = CLng(Split(A(i), "/")(1)): j = 0 Do j = j + 1 st = st & Alea_Caract$(122, 97) If Len(st) >= 2 And e Then If Similar_Characters(st) Then st = Left$(st, Len(st) - 1): j = j - 1 End If Loop While j < Nb Case "9" Nb = CLng(Split(A(i), "/")(1)): j = 0 Do j = j + 1 st = st & Alea_Caract$(57, 48) If Len(st) >= 2 And e Then If Similar_Characters(st) Then st = Left$(st, Len(st) - 1): j = j - 1 End If Loop While j < Nb Case "!" Nb = CLng(Split(A(i), "/")(1)): j = 0 Do j = j + 1 st = st & Alea_Car_Spec$ If Len(st) >= 2 And e Then If Similar_Characters(st) Then st = Left$(st, Len(st) - 1): j = j - 1 End If Loop While j < Nb End Select Next i GenerateStringAleaPattern = Shuffle_Letters(st) End Function
Ces deux fonctions utilisent les fonctions suivantes :
Retourne un caractère aléatoire, soit Majuscule, soit minuscule, soit numérique :
Retourne un caractère spécial aléatoire :
Code vba : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5 Private Function Alea_Caract(M As Long, L As Long) As String 'random 1 character in lower or upper case, or numeric Randomize Timer Alea_Caract = Chr$(Int(((M - L + 1) * Rnd) + L)) End Function
Rien de spécial, vide les 5 variables qui lui sont passées en argument :
Code vba : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6 Private Function Alea_Car_Spec() As String 'random 1 character "special" Const CHAINE = "!""#$%&'()*+,-./:;<=>?@[]_{|}~" Randomize Timer Alea_Car_Spec = Mid$(CHAINE, Int((Len(CHAINE) * Rnd) + 1), 1) End Function
Permet l'exclusion d'un caractère s'il est visuellement similaire à celui qui le précède :
Code vba : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3 Private Sub Efface(t As String, A As Boolean, b As Boolean, C As Boolean, d As Boolean) t = vbNullString: A = False: b = False: C = False: d = False End Sub
Mélange les caractères d'une chaîne :
Code vba : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11 Private Function Similar_Characters(s As String) As Boolean 'option of excluding visually similar characters Dim t, i As Long Const COUPLES As String = "Il I1 l1 lI 1l 1I ]l l] 0O O0 5S S5 2Z 2? Z? Z2 ?2 ?Z DO OD" t = Split(COUPLES, " ") For i = 0 To UBound(t) If Right$(s, 2) = t(i) Then Similar_Characters = True: Exit For End If Next End Function
Mélange les indices d'un Array à 1 dimension : (L étant l'UBound de l'array)
Code vba : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10 Private Function Shuffle_Letters(s As String) As String 'shuffle the String's letters only if pattern Dim i&, t, R As String, d() As Long t = Split(StrConv(s, vbUnicode), Chr$(0)) d = Best_shuffle(UBound(t)) For i = LBound(t) To UBound(t) R = R & t(d(i)) Next i Shuffle_Letters = Left$(R, Len(R) - 1) End Function
Code vba : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26 Private Function Best_shuffle(L As Long) As Long() Dim i As Long, ou As Long, temp() As Long Dim C As New Collection ReDim temp(L) If L = 1 Then temp(LBound(temp)) = 0 ElseIf L = 2 Then temp(LBound(temp)) = 1: temp(UBound(temp)) = 0 Else Randomize i = LBound(temp) Do ou = Int(Rnd * L) On Error Resume Next C.Add CStr(ou), CStr(ou) If Err <> 0 Then On Error GoTo 0 Else On Error GoTo 0 temp(ou) = i i = i + 1 End If Loop While C.Count <> L End If Best_shuffle = temp End Function
Vous pouvez, à loisir, modifier les deux constantes :
1- Dans la Function Alea_Car_Spec()
Const CHAINE = "!""#$%&'()*+,-./:;<=>?@[]_{|}~"
2- Dans la Function Similar_Characters()
Const COUPLES As String = "Il I1 l1 lI 1l 1I ]l l] 0O O0 5S S5 2Z 2? Z? Z2 ?2 ?Z DO OD"
Enjoy it !