Solved Detect 4 Sequential/Consecutive characters within a string (1 Viewer)

[Jason Lee Hayes]

Hi,

I am trying to increase security with regards password allowed to be used..

If the user chooses a password i have the following requirement check which works fine:-

Have at least 8 characters in length
Must have at least 2 letters (a,b,c...)
Must have at least 2 Numbers (1,2,3...)
Include both uppercase & lower case characters
Must include a special character

I also have a random password generator routine which also produces passwords conforming to the restrictions above...

What i also would like but not sure how to go about it is:

The password must not contain 4 consecutive characters (e.g. "1111", "1234", "abcd" )

Maybe using Regular Expression and a check on the increment within the ASCII table but not sure.

Anyone done something similar that could help..

Thanks in advance

 

[Jason Lee Hayes]

Hi,

I am trying to increase security with regards password allowed to be used..

If the user chooses a password i have the following requirement check which works fine:-

Have at least 8 characters in length
Must have at least 2 letters (a,b,c...)
Must have at least 2 Numbers (1,2,3...)
Include both uppercase & lower case characters
Must include a special character

I also have a random password generator routine which also produces passwords conforming to the restrictions above...

What i also would like but not sure how to go about it is:

The password must not contain 4 consecutive characters (e.g. "1111", "1234", "abcd" )

Maybe using Regular Expression and a check on the increment within the ASCII table but not sure.

Anyone done something similar that could help..

Thanks in advance

I have the following which should identify 4 of the same characters in a row:- eg (aaaa or AAAA or bbbb)
How do adapt this to check for numbers e.g. (1111, 8888)
Would it be something like .Pattern = "([a-z][1-9])\1\1\1" ?

Option Explicit
Function QuadChars(S As String) As Boolean
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = True
.Pattern = "([a-z])\1\1\1"
.ignorecase = True 'edit as desired
QuadChars = .test(S)
End With
End Function

 

[Minty]

Rather than re-invent the wheel have a look at this thread for some thoughts.

Testing password complexity through VBA

Hi, all - I've been researching how to test password complexity for an A2010 application through VBA and haven't found much. I would like a new password tested to assure it has at least 8 characters (pretty easy) and contains at least one capital letter and one number (not so easy). Has...

www.access-programmers.co.uk

 

[Jason Lee Hayes]

Rather than re-invent the wheel have a look at this thread for some thoughts.

Testing password complexity through VBA

Hi, all - I've been researching how to test password complexity for an A2010 application through VBA and haven't found much. I would like a new password tested to assure it has at least 8 characters (pretty easy) and contains at least one capital letter and one number (not so easy). Has...

www.access-programmers.co.uk

Hi,

Thanks; I'm not reinventing the wheel as such as the link provided offers me what i already know and implemented.
The specific thing I'm trying to achieve is:-

The password must not contain 4 consecutive characters (e.g. "1111", "1234", "abcd" )
Its a RexEX thing but cannot get my head around it lol

 

[Minty]

@arnelgp is the expert on-site for Reg Ex from what I remember from previous threads.
I've tagged him to give him a nudge to the thread.

If it makes you feel any better, I just don't get it despite a number of attempts.

 

[jdraw]

This should check for 4 sequential Digits (1234..) , 4 sequential lower, or 4 UPPER alphabetic chars.
I have not dealt with repeated chars (1111, dddd ..etc)
Still testing

' ----------------------------------------------------------------
' Procedure Name: quadCheck
' Purpose: Routine to check password for 4 sequential digits or 4 sequential alphabeetic
' Procedure Kind: Function
' Procedure Access: Public
' Parameter pwd (Variant): Password to be checked
' Return Type: Boolean
' Author: Jack
' Date: 08-Jan-23
' ----------------------------------------------------------------
Function quadCheck(pwd As Variant) As Boolean
          Dim alphsUC As String, alphsLC As String, nums As String
          Dim quad As String, lPwd As Integer, iloop As Integer
10        alphsUC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
20        alphsLC = "abcdefghijklmnopqrstuvwxyz"
30        nums = "01234567890"
40        If IsNull(pwd) Then
50            quadCheck = False
60            Exit Function
70        End If
80        lPwd = Len(pwd)
90        For iloop = 1 To lPwd - 3
100           quad = Mid(pwd, iloop, 4)
110           If InStr(alphsUC, quad) > 0 Or InStr(alphsLC, quad) > 0 Or InStr(nums, quad) > 0 Then
120               Debug.Print quad & "  seq chars found"
130               quadCheck = False
140               Exit Function
150           End If
160       Next
End Function

 

[Jason Lee Hayes]

This can check for 4 sequential Digits (1234..) , 4 sequential lower, or 4 UPPER alphabetic chars.
I have not dealt with repeated chars (1111, dddd ..etc)

' ----------------------------------------------------------------
' Procedure Name: quadCheck
' Purpose: Routine to check password for 4 sequential digits or 4 sequential alphabeetic
' Procedure Kind: Function
' Procedure Access: Public
' Parameter pwd (Variant): Password to be checked
' Return Type: Boolean
' Author: Jack
' Date: 08-Jan-23
' ----------------------------------------------------------------
Function quadCheck(pwd As Variant) As Boolean
          Dim alphsUC As String, alphsLC As String, nums As String
          Dim quad As String, lPwd As Integer, iloop As Integer
10        alphsUC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
20        alphsLC = "abcdefghijklmnopqrstuvwxyz"
30        nums = "01234567890"
40        If IsNull(pwd) Then
50            quadCheck = False
60            Exit Function
70        End If
80        lPwd = Len(pwd)
90        For iloop = 1 To lPwd - 3
100           quad = Mid(pwd, iloop, 4)
110           If InStr(alphsUC, quad) > 0 Or InStr(alphsLC, quad) > 0 Or InStr(nums, quad) > 0 Then
120               Debug.Print quad & "  seq chars found"
130               quadCheck = False
140               Exit Function
150           End If
160       Next
End Function

Excellent; this gets me closer to my goal...

Sequential numbers are found using the code but UPPER case & LOWER case don't work for me...

Thank you...

 

[jdraw]

Try this one instead (binary compare).
See tests below. This exits on first invalid (sequential quad of chars) condition
Note: This will highlight 0123 and 7890 as sequential. You can adjust as needed.

' ----------------------------------------------------------------
' Procedure Name: quadCheck
' Purpose: Routine to check password for 4 sequential digits or 4 sequential alphabetic
' Uses binaryCompare to prevent  bCDe RStU erroneous detection
' Procedure Kind: Function
' Procedure Access: Public
' Parameter pwd (Variant): Password to be checked
' Return Type: Boolean
' Author: Jack
' Date: 08-Jan-23
'tested with  ?quadcheck("abQRwST459789ghij")
' ----------------------------------------------------------------
Function quadCheck(pwd As Variant) As Boolean
          Dim alphsUC As Variant, alphsLC As Variant, nums As String
          Dim quad As Variant, lPwd As Integer, iloop As Integer
10        alphsUC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
20        alphsLC = "abcdefghijklmnopqrstuvwxyz"
30        nums = "01234567890"
40        If IsNull(pwd) Then
50            quadCheck = False
60            Exit Function
70        End If
80        lPwd = Len(pwd)
90        For iloop = 1 To lPwd - 3
100           quad = Mid(pwd, iloop, 4)
110           If InStr(1, alphsUC, quad, vbBinaryCompare) > 0 Or _
                 InStr(1, alphsLC, quad, vbBinaryCompare) > 0 Or _
                 InStr(1, nums, quad) Then
120               ' Debug.Print quad & "  seq chars found"
130               quadCheck = False
140               Exit Function
150           End If
160       Next
End Function

Tests:
?quadcheck("aBCGDE453qrsto") 'picks qrst
qrst seq chars found
False

?quadcheck("aBCDQWE453qrsto") 'does not pick aBCD
qrst seq chars found
False

?quadcheck("aBCDQWXYZE453qrsto") 'finds WXYZ before qrst
WXYZ seq chars found
False

?quadcheck("aBCD6789QWXYZE453qrsto") 'sequential digits 6789
6789 seq chars found
False

 

[Jason Lee Hayes]

Try this one instead (binary compare).
See tests below. This exits on first invalid (sequential quad of chars) condition
Note: This will highlight 0123 and 7890 as sequential. You can adjust as needed.

' ----------------------------------------------------------------
' Procedure Name: quadCheck
' Purpose: Routine to check password for 4 sequential digits or 4 sequential alphabetic
' Uses binaryCompare to prevent  bCDe RStU erroneous detection
' Procedure Kind: Function
' Procedure Access: Public
' Parameter pwd (Variant): Password to be checked
' Return Type: Boolean
' Author: Jack
' Date: 08-Jan-23
'tested with  ?quadcheck("abQRwST459789ghij")
' ----------------------------------------------------------------
Function quadCheck(pwd As Variant) As Boolean
          Dim alphsUC As Variant, alphsLC As Variant, nums As String
          Dim quad As Variant, lPwd As Integer, iloop As Integer
10        alphsUC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
20        alphsLC = "abcdefghijklmnopqrstuvwxyz"
30        nums = "01234567890"
40        If IsNull(pwd) Then
50            quadCheck = False
60            Exit Function
70        End If
80        lPwd = Len(pwd)
90        For iloop = 1 To lPwd - 3
100           quad = Mid(pwd, iloop, 4)
110           If InStr(1, alphsUC, quad, vbBinaryCompare) > 0 Or _
                 InStr(1, alphsLC, quad, vbBinaryCompare) > 0 Or _
                 InStr(1, nums, quad) Then
120               ' Debug.Print quad & "  seq chars found"
130               quadCheck = False
140               Exit Function
150           End If
160       Next
End Function

Tests:
?quadcheck("aBCGDE453qrsto") 'picks qrst
qrst seq chars found
False

?quadcheck("aBCDQWE453qrsto") 'does not pick aBCD
qrst seq chars found
False

?quadcheck("aBCDQWXYZE453qrsto") 'finds WXYZ before qrst
WXYZ seq chars found
False

?quadcheck("aBCD6789QWXYZE453qrsto") 'sequential digits 6789
6789 seq chars found
False

HI,

Yes; appreciate the update... This one works well... Much appreciated....

 

[Minty]

Just to not really help but this link might float your Reg Ex Boat a bit.

Check three or more consecutive identical characters or numbers - GeeksforGeeks

A Computer Science portal for geeks. It contains well written, well thought and well explained computer science and programming articles, quizzes and practice/competitive programming/company interview Questions.

www.geeksforgeeks.org

 

[jdraw]

I think this one (small edit to your demo) could work for repeat chars.

' ----------------------------------------------------------------
' Procedure Name: QuadChars
' Purpose: Routine to check for 4 repeats of  alphLC/Uc or numeric digit
' Procedure Kind: Function
' Procedure Access: Public
' Parameter S (Variant): Password string to be tested
' Return Type: Boolean
' Author: Jack
' Date: 08-Jan-23
'The result is TRUE if there is a pattern match!!!!!!!!!
'Based on your password validation, a positive pattern match signifies
'an Invalid Password
'
'You may want to negate the QuadChars result to indicate Invalid Password
' eg. QuadChars = Not QuadChars
' ----------------------------------------------------------------
Function QuadChars(S As Variant) As Boolean
          Dim RE As Object
10        If IsNull(S) Then
20        QuadChars = False
30        Exit Function
40        End If
50        Set RE = CreateObject("vbscript.regexp")
60        With RE
70            .Global = True
80            .Pattern = "([0-9A-z])\1\1\1"
90            .IgnoreCase = False 'edit as desired
100           QuadChars = .test(S)
110       End With
End Function

Tests:
?quadchars("1233abccc3335768") '3 contiguous "c" Valid PWD (pattern NOT FOUND)
False
?quadchars("1233abcccc3335768") '4 contiguous "c" Invalid PWD (Pattern found)
True
?quadchars("1233abcCcc3335768") 'cCcc is not considered a pattern match (I set ignore case False)
False
?quadchars("1233abcCc7777c3335768") ' works with digits 7777 also
True

 

[The_Doc_Man]

No code samples, but this observation: Having the "no strings of N duplicated characters" requires that you remember the last N-1 characters for each comparison. When I implemented this kind of filter for OpenVMS logins, there was no alternative but to take each character one at a time to do the counts for character types and then use a "brute force" method for that "duplicate sequence" case. In my case, the password was offered as a string so it was easier to use the "MID" function to pick it apart.

Whether you treat the characters of that password as an array of individual characters or as a string, single-character access was mandatory. Not the it matters that much, but our password rules were "2 of each of the four character types" and "14 characters for non-privileged passwords, 15 for privileged" - and we had the "no repetitious character sequence" requirement as well. Wouldn't do you any good to show you that code because it wasn't in VBA. But it was U.S. Navy code and I didn't own it so wasn't allowed to keep a copy when I retired.

 

[ebs17]

I also have a suggestion that I'm sure you could add some additional requirements to.

Function TestPassword(sPW As String) As Boolean
    Dim bytArrPW() As Byte
    Dim sDiff() As String
    Dim lCount As Long
    Dim bRet As Boolean
    Dim bRepeat As Boolean
    Dim sAll As String
    Dim sSeries As String
    Dim i As Long
    Dim lNumber As Long
    Dim lUppercase As Long
    Dim lLowercase As Long
    Dim lSpecialCharacter As Long

    bytArrPW() = sPW
    lCount = UBound(bytArrPW)
    ReDim sDiff(lCount / 2)
    For i = 0 To lCount Step 2
        Select Case bytArrPW(i)
            Case 48 To 57
                lNumber = lNumber + 1
            Case 65 To 90
                lUppercase = lUppercase + 1
            Case 97 To 122
                lLowercase = lLowercase + 1
            Case 33 To 47, 58 To 64, 91 To 96
                lSpecialCharacter = lSpecialCharacter + 1
        End Select
    Next
    bRet = Len(sPW) > 7 And lNumber > 1 And lUppercase > 0 And lLowercase > 0 And lSpecialCharacter > 0
    'Debug.Print bRet
   
    For i = 2 To lCount Step 2
        sDiff(i / 2) = CLng(bytArrPW(i)) - CLng(bytArrPW(i - 2))
    Next
    sSeries = Join(sDiff, "|")
    If InStr(1, sSeries, "0|0|0|") > 0 Or InStr(1, sSeries, "1|1|1|") > 0 Then bRepeat = True
    ' Debug.Print bRepeat

    TestPassword = bRet And Not bRepeat
   
End Function

Sub call_TestPassword()
    Debug.Print TestPassword("TaaaaB23ad@x")
End Sub

 

[Jason Lee Hayes]

I think this one (small edit to your demo) could work for repeat chars.

' ----------------------------------------------------------------
' Procedure Name: QuadChars
' Purpose: Routine to check for 4 repeats of  alphLC/Uc or numeric digit
' Procedure Kind: Function
' Procedure Access: Public
' Parameter S (Variant): Password string to be tested
' Return Type: Boolean
' Author: Jack
' Date: 08-Jan-23
'The result is TRUE if there is a pattern match!!!!!!!!!
'Based on your password validation, a positive pattern match signifies
'an Invalid Password
'
'You may want to negate the QuadChars result to indicate Invalid Password
' eg. QuadChars = Not QuadChars
' ----------------------------------------------------------------
Function QuadChars(S As Variant) As Boolean
          Dim RE As Object
10        If IsNull(S) Then
20        QuadChars = False
30        Exit Function
40        End If
50        Set RE = CreateObject("vbscript.regexp")
60        With RE
70            .Global = True
80            .Pattern = "([0-9A-z])\1\1\1"
90            .IgnoreCase = False 'edit as desired
100           QuadChars = .test(S)
110       End With
End Function

Tests:
?quadchars("1233abccc3335768") '3 contiguous "c" Valid PWD (pattern NOT FOUND)
False
?quadchars("1233abcccc3335768") '4 contiguous "c" Invalid PWD (Pattern found)
True
?quadchars("1233abcCcc3335768") 'cCcc is not considered a pattern match (I set ignore case False)
False
?quadchars("1233abcCc7777c3335768") ' works with digits 7777 also
True

YEY; now works as required... Perfect... Thankyou

 

[ebs17]

.Pattern = "([0-9A-z])\1\1\1"

' can also be represented as
.Pattern = "[0-9A-z]{4}"

 

[Jason Lee Hayes]

I also have a suggestion that I'm sure you could add some additional requirements to.

Function TestPassword(sPW As String) As Boolean
    Dim bytArrPW() As Byte
    Dim sDiff() As String
    Dim lCount As Long
    Dim bRet As Boolean
    Dim bRepeat As Boolean
    Dim sAll As String
    Dim sSeries As String
    Dim i As Long
    Dim lNumber As Long
    Dim lUppercase As Long
    Dim lLowercase As Long
    Dim lSpecialCharacter As Long

    bytArrPW() = sPW
    lCount = UBound(bytArrPW)
    ReDim sDiff(lCount / 2)
    For i = 0 To lCount Step 2
        Select Case bytArrPW(i)
            Case 48 To 57
                lNumber = lNumber + 1
            Case 65 To 90
                lUppercase = lUppercase + 1
            Case 97 To 122
                lLowercase = lLowercase + 1
            Case 33 To 47, 58 To 64, 91 To 96
                lSpecialCharacter = lSpecialCharacter + 1
        End Select
    Next
    bRet = Len(sPW) > 7 And lNumber > 1 And lUppercase > 0 And lLowercase > 0 And lSpecialCharacter > 0
    'Debug.Print bRet
  
    For i = 2 To lCount Step 2
        sDiff(i / 2) = CLng(bytArrPW(i)) - CLng(bytArrPW(i - 2))
    Next
    sSeries = Join(sDiff, "|")
    If InStr(1, sSeries, "0|0|0|") > 0 Or InStr(1, sSeries, "1|1|1|") > 0 Then bRepeat = True
    ' Debug.Print bRepeat

    TestPassword = bRet And Not bRepeat
  
End Function

Sub call_TestPassword()
    Debug.Print TestPassword("TaaaaB23ad@x")
End Sub

Hi,

Just looking at this now... Works perfectly and all wrapped up into 1 function which i like.

Thankyou

 

[Jason Lee Hayes]

.Pattern = "([0-9A-z])\1\1\1"

' can also be represented as
.Pattern = "[0-9A-z]{4}"

Thanks; will add this as a remark within the code... Thankyou

 

[ebs17]

Addendum to TestPassword: You can also define the return value as a string and use "OK" for True. You can create your own messages for unfulfilled conditions (lNumber >1) and thus better inform the user.

 

[Jason Lee Hayes]

Hi,

Just looking at this now... Works perfectly and all wrapped up into 1 function which i like.

Thankyou

Hi,

I have looked at what i have and the alternatives and after testing your code it actually works perfect. This means i can get rid of 2 separate modules, bin my RegEX and simply apply your code.

What's more; on my original protect design after each keypress in the password field i display a picture representing how secure the password is depending on what characters have been typed and checked. The image represents stage conformity reached therefore 8 characters or more would be 20%, more than 2 Uppercase as well 40%, 2 lower aswell 60%, a special character 80% etc

Your code allows me to add a value to each stage of progression therefore allowing me to change the image to represent the percentage...

Excellent Thankyou

 

[jdraw]

A question for Jason:

Do you accept or reject a string such as "cCcc"?
Are you differentiating upper/lower case chars?