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

Jason Lee Hayes

Jason Lee Hayes

Active member
Local time
Today, 16:36
Joined
Jul 25, 2020
Messages
196
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 said:
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
Click to expand...

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
 
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
 
Minty said:
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
Click to expand...
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
 
@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. :unsure:
 
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

Code: 
' ----------------------------------------------------------------
' 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
 
Last edited:
jdraw said:
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)

Code: 
' ----------------------------------------------------------------
' 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
Click to expand...
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...
 
Last edited:
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.

Code: 
' ----------------------------------------------------------------
' 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
 
jdraw said:
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.

Code: 
' ----------------------------------------------------------------
' 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
Click to expand...

HI,

Yes; appreciate the update... This one works well... Much appreciated....
 
I think this one (small edit to your demo) could work for repeat chars.

Code: 
' ----------------------------------------------------------------
' 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
 
Last edited:
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.
 
I also have a suggestion that I'm sure you could add some additional requirements to.
Code: 
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
 
Last edited:
jdraw said:
I think this one (small edit to your demo) could work for repeat chars.

Code: 
' ----------------------------------------------------------------
' 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
Click to expand...

YEY; now works as required... Perfect... Thankyou
 
Code: 
.Pattern = "([0-9A-z])\1\1\1"

' can also be represented as
.Pattern = "[0-9A-z]{4}"
 
ebs17 said:
I also have a suggestion that I'm sure you could add some additional requirements to.
Code: 
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
Click to expand...
Hi,

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

Thankyou
 
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 said:
Hi,

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

Thankyou
Click to expand...
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
 
A question for Jason:

Do you accept or reject a string such as "cCcc"?
Are you differentiating upper/lower case chars?
 
You must log in or register to reply here.

Similar threads

brucemc777
Solved HOW??? An HTML string stored in a long text table field with breaks for variables to be used in boilerplate eMails...
Replies
10
Views
368
brucemc777
brucemc777
N
Solved How to changes thousands of products prices in a retail business (The backed is SQL Server AZURE)
Replies
3
Views
493
nector
N
J
Promotion of short procedures: Splitting a string into lines
Replies
0
Views
595
Josef P.
J
A
Run-time error 52 Bad file name or number
Replies
11
Views
1,257
Pat Hartman
P
J
Interesting artical about what government can and can't do. It's a bit longish, but worth the read.
Replies
19
Views
533
moke123
moke123

Users who are viewing this thread

Total: 2 (members: 0, guests: 2)
Back
Top Bottom