pijaku

___________________________________________________________________________________

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 :

1. n As Long : la longueur de la chaîne voulue (minimum 4 caractères),
2. 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 :

1. s As String : le "pattern" souhaité (cf exemple ci-dessous),
2. 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 :

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

Retourne un caractère spécial aléatoire :

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

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
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

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
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 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
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

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
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 !