Stellt aufgrund eines Patterns ein Zufallstext zusammen. zB. für ein Passwortgenerator

Download udf_rndstring.bas (V-1.0.1)

String = rndString(pattern)

'/**
' * Erstellt ein Zfallswerd gemäss Patterndefinition
' * @example    rndString("L(a{10}[\#\_\-\|])") -> fo2kvnx1#c8z725
' * @param  String      Pattern
' * @return String
' */
Public Function rndString(ByVal iPattern As String) As String

Die Anwendungen findest du in den Beispielen

• a Lower-Case Alphanumeric abcdefghijklmnopqrstuvwxyz 0123456789
• A Mixed-Case Alphanumeric ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz 0123456789
• U Upper-Case Alphanumeric ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789
• d Digit 0123456789
• h Lower-Case Hex Character 0123456789 abcdef
• H Upper-Case Hex Character 0123456789 ABCDEF
• l Lower-Case Letter abcdefghijklmnopqrstuvwxyz
• L Mixed-Case Letter ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz
• u Upper-Case Letter ABCDEFGHIJKLMNOPQRSTUVWXYZ
• p Punctuation ,.;:
• b Bracket ()[]{}<>
• s Printable 7-Bit Special Character !“#$%&'()*+,-./:;⇔?@[\]^_`{|}~
• S Printable 7-Bit ASCII A-Z, a-z, 0-9, !”#$%&'()*+,-./:;⇔?@[\]^_`{|}~

• […] Mehrfachauswahl. Eines der Pattern davon wird verwendet
• {#} Anzahl Zeichen
• {#,#} Mindestens und Maximal Anzahl Zeichen
• (…) Alle Patterns innerhalb der Klammern kommen vor. Die Reihenfolge wird gemischt
• \ Das folgende Zeichen ist kein Pattern sondern das Zeichen selber
• ^* Das folgende Zeichen/Pattern wird von vorgehenden Pattern abgezogen. a^d entspricht somit dem l

Einfache Beispiele.

'5 Zeichen aus dem Sortiment a-zA-Z0-9
?rndString("A{5}")
V6lfN
 
'Im Vergleich dazu, 5 mal den Buchstaben a
?rndString("\a{5}")
aaaaa
 
'5 Zeichen, die entweder ein Punkt- oder ein Klammerzeichen oder ein Kleinbuchstabe sind
?rndString("[pbl]{5}")
f>;g(
 
'dasselbe, aber mindestesn 4 Zeichen, maximal 10 Zeichen
?rndString("[pbl]{4, 10}")
{}m>,>ion]

Zusammengesetzt Pattern

'Ein Buchstabe (Gross und Klein). gefolgt von 2 Ziffern. 
'Dann ein Satzzeichen oder ein Klammerzeichen und zum Schluss nochmals ein Buchstaben 
?rndString("Ld{2}[pb]L")
z06[z
 
'dasselbe. Aber abgeseehn vom ersten Zeichen ist der Rest in () gefasst und wird somit wild gemischt
?rndString("L(d{2}[pb]L)")
r.R76

Zeichen aus einem Pattern ausschliessen mit ^

'16 Ziffern ohne die 0
?rndString("d^\0{16}")
6719115112343998
 
'10 Sonderzeichen ohne Klammern und Punkte
?rndString("s^[pb]{10}")
%*"|?+'`=&

Und noch ein nützliches Beispiel.

'Ein Passwort. Beginnt mit einem Buchstaben. 
'Dann kommt ein Teil, bestehend aus 8 Buchstaben+Zahlen und 2 Sonderzeichen ohne Punkte und Klammern.
?rndString("L(a{8}s^[pb]{2})")
C$zr%i6z3md

udf_rndstring.bas

Attribute VB_Name = "udf_rndString"
'-------------------------------------------------------------------------------
'File         : udf_rndString.bas
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba
'Environment  : VBA 2010 +
'Version      : 1.0.1
'Name         : rndString
'Author       : Stefan Erb (ERS)
'History      : 04.05.2017 - ERS - Creation
'               04.09.2019 - ERS - Array() durch emptyArrayVariant() ersetzt
'-------------------------------------------------------------------------------
Option Explicit
 
'Set:       [...]   Einfach bunt gemischt
'           (...)   Von jedem muss etwas vorhanden sein
'Repeat:    {x}     Anzahl x Zeichen
'           {y, x}  Mindestens y Zeichen, maximal x Zeichen
'           \       Escapen
'           ^       Exclude
 
'---------------------------------------------L----------------------------------
' Private Members
'-------------------------------------------------------------------------------
'Im Moment umgesetzte Patterns. Reiehnfolge muss mit getValiableChars() �bereinstimmen
Private Const C_AVIABLE_PATTERN_CHARS = "dluLaUApbsS"
 
Private Declare Function emptyArrayVariant Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbVariant, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Variant()
 
'Analog zu KeePass
Private Const C_DIGIT = "0123456789"                                        'd Digit
Private Const C_LOWER_LETTER = "abcdefghijklmnopqrstuvwxyz"                 'l Lower-Case Letter
Private Const C_UPPER_LETTER = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"                 'u Upper-Case Letter
Private Const C_MIXED_LETTER = C_LOWER_LETTER & C_UPPER_LETTER              'L Mixed-Case Letter
Private Const C_LOWER_ALPAH = C_LOWER_LETTER & C_DIGIT                      'a Lower-Case Alphanumeric
Private Const C_UPPER_ALPAH = C_UPPER_LETTER & C_DIGIT                      'U Upper-Case Alphanumeric
Private Const C_MIXED_ALPHA = C_UPPER_LETTER & C_LOWER_LETTER & C_DIGIT     'A Mixed-Case Alphanumeric
Private Const c_PUNCTUATION = ",.;:"                                        'p Punctuation
Private Const C_BRACKET = "()[]{}<>"                                        'b Bracket
Private Const C_SPEZ_CHARS = "!""#$%&'()*+,-./:;<=>?@[\]^_`{|}~"            's Printable 7-Bit Special Character
Private Const C_ASCII_CHARS = C_MIXED_ALPHA & C_SPEZ_CHARS                  'S Printable 7-Bit ASCII
 
'Pattern f�r den Repeat
Private Const P_REPEAT = "(?:\}(?!\\)(\d+)(?:\s*,\s*(\d+))?\{(?!\\))?"
 
'-------------------------------------------------------------------------------
' Public Methodes
'-------------------------------------------------------------------------------
 
'/**
' * Erstellt ein Zfallswerd gem�ss Patterndefinition
' * @example    rndString("L(a{10}[\#\_\-\|])") -> fo2kvnx1#c8z725
' * @param  String      Pattern
' * @return String
' */
Public Function rndString(ByVal iPattern As String) As String
    Dim tmp         As String:  tmp = StrReverse(iPattern)
    Dim resultRev   As String
    Dim retArr()    As Variant
    Dim mixArr()    As Variant
 
    Do While rxSetRev.test(tmp)
        Dim m As Object: Set m = rxSetRev.execute(tmp)(0)
        'Parsen was vor den <> steht
        If m.firstIndex > 0 Then
            parseCharSetRev Left(tmp, m.firstIndex), retArr
        End If
        mixArr = emptyArrayVariant
        parseCharSetRev m.subMatches(0), mixArr
        'mischen
        mixArray mixArr
 
        pushArray retArr, Join(mixArr, "")
        tmp = rxSetRev.replace(tmp, "")
        tmp = Mid(tmp, m.firstIndex + 1)
 
    Loop
    'Rest parsen
    parseCharSetRev tmp, retArr
    rndString = StrReverse(Join(retArr, ""))
End Function
 
'-------------------------------------------------------------------------------
' Private Methodes
'-------------------------------------------------------------------------------
 
'/**
' * Parst CharSets [...]
' * @param  String
' * @param  Array<String>
' */
Private Sub parseCharSetRev(ByVal iPattern As String, ByRef ioArray() As Variant)
    Dim tmp         As String:  tmp = iPattern
    Dim m           As Object
 
    'Sucht nach Charsets [....] und wertet sie aus
    Do While rxCharSetRev.test(tmp)
        Set m = rxCharSetRev.execute(tmp)(0)
        'Vor dem Charset hat es noch Text. Diesen parsen
        If m.firstIndex > 0 Then
            parseCharsRev Left(tmp, m.firstIndex), ioArray
        End If
        'Charsetauswerten
        Dim repeat  As Long:    repeat = getRepeat(m.subMatches(0), m.subMatches(1))
        parsePattern m.subMatches(2), repeat, ioArray
        tmp = rxCharSetRev.replace(tmp, "")
        tmp = Mid(tmp, m.firstIndex + 1)
    Loop
    'Reststring noch auswerten
    If Len(tmp) > 0 Then
        parseCharsRev tmp, ioArray
    End If
End Sub
 
'/**
' * Parst Einzelcharakters
' * @param  String
' * @param  Array<String>
' */
Private Sub parseCharsRev(ByVal iPattern As String, ByRef ioArray() As Variant)
    Dim tmp As String:  tmp = iPattern
    Dim exclude As String
 
    'Sucht nach Patterns
    Do While rxCharRev.test(tmp)
        Dim m       As Object:  Set m = rxCharRev.execute(tmp)(0)
        Dim repeat  As Long:    repeat = getRepeat(m.subMatches(0), m.subMatches(1))
        If Not isEmpty(m.subMatches(5)) Then
            exclude = getValiableChars(m.subMatches(2))
            'Einzelpattern auswerten
            parsePattern m.subMatches(5), repeat, ioArray, exclude
        ElseIf Not isEmpty(m.subMatches(4)) Then
            'Treffer f�r Fixe Werte
            pushArray ioArray, String(repeat, m.subMatches(4))
        End If
        tmp = rxCharRev.replace(tmp, "")
    Loop
 
End Sub
 
'/**
' * Parst Patterrns
' * @param  String
' * @param  Long
' * @param  Array<String>
' *
Private Sub parsePattern(ByVal iCharPattern As String, ByVal iRepeat As Long, ByRef ioArray() As Variant, Optional ByVal iExclude As String = Empty)
    Dim chars   As String:  chars = getValiableChars(iCharPattern, iExclude)
    Dim i As Long: For i = 1 To iRepeat
        Dim rndPos As Long: rndPos = rndBetween(Len(chars), 1)        'Int(Len(chars) * Rnd(Now / 1000)) + 1
        pushArray ioArray, Mid(chars, rndPos, 1)
    Next i
End Sub
 
 
'/**
' * Setzt die m�glichen Zeichen zu einem String zusammen
' * @param  String  Pattern
' * @return String
' */
Public Function getValiableChars(ByVal iPattern As String, Optional ByVal iExclude As String = Empty) As String
    Dim tmp As String: tmp = iPattern
    Dim chars As String
    Dim m As Object
 
    Do While rxEscapedRev.test(tmp)
        Set m = rxEscapedRev.execute(tmp)(0)
        chars = chars & m.subMatches(0)
        tmp = rxEscapedRev.replace(tmp, "")
        'tmp = Left(tmp, m.firstIndex) & Mid(tmp, m.firstIndex + m.length + 1)
    Loop
 
    Dim i As Long: For i = 1 To Len(tmp)
        chars = chars & NZ(Choose(InStr(1, C_AVIABLE_PATTERN_CHARS, Mid(tmp, i, 1), vbBinaryCompare), _
            C_DIGIT, _
            C_LOWER_LETTER, C_UPPER_LETTER, C_MIXED_LETTER, _
            C_LOWER_ALPAH, C_UPPER_ALPAH, C_MIXED_ALPHA, _
            c_PUNCTUATION, C_BRACKET, C_SPEZ_CHARS, C_ASCII_CHARS _
        ))
    Next i
    getValiableChars = removeDoupleChars(chars)
    getValiableChars = removeChars(getValiableChars, iExclude)
End Function
 
'/**
' * Mischt ein Array durch
' * @param  Array
' */
Private Sub mixArray(ByRef ioArray As Variant)
    Dim delta       As Long:    delta = LBound(ioArray)
    Dim maxI        As Long:    maxI = UBound(ioArray)
    Dim index()     As Long:    ReDim index(maxI - delta)
    Dim retArr()    As Variant: ReDim retArr(LBound(ioArray) To UBound(ioArray))
 
    'Index aufbauen
    Dim i As Long:  For i = 0 To maxI
        index(i) = i + delta
    Next i
 
    'ANzahl mal ausw�rfeln
    For i = maxI To 0 Step -1
        Dim idx As Long: idx = Int((i + 1) * Rnd(Now / 1000))
        retArr(i + delta) = ioArray(index(idx))
        If i > 0 Then arrayRemoveItem index, idx
    Next i
 
    ioArray = retArr
End Sub
 
'/**
' * Ermittelt den Repeat-Wert
' * @param  Variant Upper Limit
' * @param  Variant Lower Limit
' * @return Long
' */
Private Function getRepeat(ByVal iUpper As Variant, Optional ByVal iLower As Variant = Empty) As Long
    getRepeat = 1
    If NZ(iUpper) = Empty Then Exit Function
    getRepeat = CLng(StrReverse(iUpper))
    If NZ(iLower) = Empty Then Exit Function
    getRepeat = rndBetween(getRepeat, CLng(StrReverse(iLower)))
End Function
 
'/**
' * Runden mit Limiten
' * @param  Variant Upper Limit
' * @param  Variant Lower Limit
' * @return Long
' */
Public Function rndBetween(ByVal iUpper As Long, Optional ByVal iLower As Long = 0) As Long
    rndBetween = Int((iUpper - iLower + 1) * Rnd(Rnd) + iLower)
End Function
 
 
'/**
' * F�gt einen Eintrag am Ende eines Arrays ein
' * @param  Array
' * @param  Variant
' */
Private Function pushArray(ByRef ioArray() As Variant, ByVal iValue As Variant)
    Dim idx As Long
On Error Resume Next
    idx = UBound(ioArray) + 1
    If Err.Number <> 0 Then idx = 0
On Error GoTo 0
    ReDim Preserve ioArray(idx)
    ioArray(idx) = iValue
End Function
 
'/**
'* Entfernt ein Eintrag aus einem Array und verk�rzt diesen
' * @param  Variant Der zu verk�rzende Array
' * @param  Long    Index der gel�scht werden soll
' */
Private Function arrayRemoveItem(ByRef ioArray As Variant, ByVal iIndex As Long) As Variant
    If iIndex < LBound(ioArray) Or UBound(ioArray) < iIndex Then Exit Function
    If LBound(ioArray) = UBound(ioArray) Then ioArray = emptyArrayVariant:   Exit Function
 
    'Ab dem zu l�schenden index alles um eins Nach vorne schieben
    Dim i As Long: For i = iIndex To UBound(ioArray) - 1
        ioArray(i) = ioArray(i + 1)
    Next i
    'Den Array verk�rzen
    ReDim Preserve ioArray(LBound(ioArray) To UBound(ioArray) - 1)
End Function
 
'/**
' * entfernt doppelte Zeichen in einem String.
' * @example    removeDoupleChars("abcABdef")   -> abcABdef
' *             removeDoupleChars("abcABdef", vbTextCompare) -> abcdef
' * @param  String
' * @param  VbCompareMethod
' * @return String
' */
Private Function removeDoupleChars(ByVal iText As String, Optional ByVal iCompMethode As VbCompareMethod = vbBinaryCompare) As String
    removeDoupleChars = iText
    Dim i As Long: For i = Len(iText) To 1 Step -1
        If InStr(1, Left(removeDoupleChars, i - 1), Mid(removeDoupleChars, i, 1), iCompMethode) > 0 Then
            removeDoupleChars = Left(removeDoupleChars, i - 1) & Mid(removeDoupleChars, i + 1)
        End If
    Next i
End Function
 
'/**
' * entfernt ein spezifisches Zeichen in einem String.
' * @param  String
' * @param  String
' * @param  VbCompareMethod
' * @return String
' */
Public Function removeChar(ByVal iText As String, ByVal iChar As String, Optional ByVal iCompMethode As VbCompareMethod = vbBinaryCompare) As String
    removeChar = iText
    If iChar = Empty Then Exit Function
    Dim pos As Long:    pos = InStr(1, removeChar, iChar, iCompMethode)
    Do While Not pos = 0
        removeChar = Left(removeChar, pos - 1) & Mid(removeChar, pos + Len(iChar))
        pos = InStr(1, removeChar, iChar, iCompMethode)
    Loop
End Function
 
Public Function removeChars(ByVal iText As String, ByVal iChars As String, Optional ByVal iCompMethode As VbCompareMethod = vbBinaryCompare) As String
    removeChars = iText
    Dim i As Long: For i = 1 To Len(iText)
        removeChars = removeChar(removeChars, Mid(iChars, i, 1), iCompMethode)
    Next i
End Function
 
'-------------------------------------------------------------------------------
' Private Properties
'-------------------------------------------------------------------------------
 
'/**
' * Achtung: Geht nur mit Reverse String
' * (patterb)
' * 0: Pattern
' * @return RegExp
' */
Private Property Get rxSetRev() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/\)(?!\\)(.*?)\((?!\\)/")
    Set rxSetRev = rx
End Property
 
'/**
' * Achtung: Geht nur mit Reverse String
' * [charSet]{repeatMin,repeatMax}
' * 0: RepeatMax    1: RepeatMin       2: CharSet
' * @return RegExp
' */
Private Property Get rxCharSetRev() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/" & P_REPEAT & "\](?!\\)(.*?)\[(?![\\\^])/")
    Set rxCharSetRev = rx
End Property
 
'/**
' * Achtung: Geht nur mit Reverse String
' * Pattern{repeatMin,repeatMax} oder \EcscapedWert{repeatMin,repeatMax}
' * 0: RepeatMax    1: RepeatMin       3: ExcludePattern    4: Escapten Wert        5: Patternwert
' * @return RegExp
' */
Private Property Get rxCharRev() As Object
    '"/" & P_REPEAT & "(?:((.)\\)|([" & C_AVIABLE_PATTERN_CHARS & "](?!\\)))/"  ===> (?:\}(?!\\)(\d+)(?:\s*,\s*(\d+))?\{(?!\\))?(?:((.)\\)|([dluLaUApbsS](?!\\)))
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/" & P_REPEAT & "(?:(.+)\^)?(?:((.)\\)|([" & C_AVIABLE_PATTERN_CHARS & "](?!\\)))/")
    Set rxCharRev = rx
End Property
 
'/**
' * Achtung: Geht nur mit Reverse String
' * Escapten Wert
' * @return RegExp
' */
Private Property Get rxEscapedRev() As Object
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/(.)\\(?!\\)/")
    Set rxEscapedRev = rx
End Property
 
'-------------------------------------------------------------------------------
' Private Libraries
'-------------------------------------------------------------------------------
 
'/**
' * Dies ist die Minimalversion von cRegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version
' * m�gliche Delemiter: @&!/~#=\|
' * m�gliche Modifiers: g (Global), i (IgnoreCode, m (Mulitline)
' *
' * @example    myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase
' * @version    2.1.0 (01.12.2014)
' * @param      String      Pattern mit Delimiter und Modifier analog zu PHP
' * @return     Object      RegExp-Object
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object:       Set cRx = CreateObject("VBScript.RegExp")
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set sm = rxP.execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function