Password Creation

Send Snippet To: Save this snippet to Code Collector Pro -- view all surfrgeek's snippets
language: Other
license: Other

Code for Snippet:

                
Sub Password()
    Dim pass1, pass2, userInput, numericCount, midChar As String
    Dim isPasswordUnique, isValid As Boolean
    Dim passwordCells As Range
    Dim pos28 As Integer
 
 
    ' Ask for valid password until unique.
    Do
        ' Ask for password until clears validation.
        Do
            isValid = True
            userInput = InputBox("Please enter a password that meets this criteria:" & vbNewLine & vbNewLine & _
            "First character must be a capital letter." & vbNewLine & _
            "Password must be 8 chacters in length." & vbNewLine & _
            "All characters must be capital letters or digits." & vbNewLine & _
            "No more than 2 numeric digits.", "Password" & vbNewLine)
 
            ' Blank entry check.
            If userInput <> "" Then
                pass1 = userInput
 
                ' Length check.
                If Len(pass1) <> 8 Then
                    isValid = False
 
                ' First character capital check.
                ElseIf Not (Left(pass1, 1) >= "A" And Left(pass1, 1) <= "Z") Then
                    isValid = False
 
 
                ' Other characters check.
                Else
                    ' 2 or less numeric value check
                    numericCount = 0
                    For pos28 = 2 To 8
                        midChar = Mid(pass1, pos28, 1)
                        If midChar >= "0" And midChar <= "9" Then
                            numericCount = numericCount + 1
                        End If
                    Next
 
                    If numericCount > 2 Then
                        isValid = False
 
                    Else
                    ' 2 to 8 character check
                    For pos28 = 2 To 8
                        midChar = Mid(pass1, pos28, 1)
                        If Not ((midChar >= "A" And midChar <= "Z") Or _
                                (midChar >= "0" And midChar <= "9")) Then
                            isValid = False
                            Exit For
                        End If
                    Next
                End If
            End If
 
            If Not isValid Then
                MsgBox "The password is not valid.", vbInformation, "Invalid"
            End If
        Loop Until userInput <> "" And isValid
 
        Set passwordCells = ActiveWorkbook.Worksheets("Password").Range("A1")
 
        ' If password valid check against password list
        isPasswordUnique = True
        Do Until passwordCells = ""
            If pass1 = passwordCells.Value Then
                isPasswordUnique = False
                Exit Do
            End If
            ' Next cell
            Set passwordCells = passwordCells.Offset(1, 0)
        Loop
 
        If Not isPasswordUnique Then
            MsgBox "The password you entered, " & pass1 & ", is valid, but, " _
                & "already in use. Try another password.", vbInformation, "Password in use."
        Else
            pass2 = InputBox("Please reenter your password for verification.")
            If pass2 <> pass1 Then
                MsgBox "The passwords do not match. Please try again.", vbInformation, "No verification"
            Else
                MsgBox "Congrats! Your new password is " & pass1 & ".", _
                    vbInformation, "Password Set"
 
                ' Add new password to password list.
                ActiveWorkbook.Worksheets("Password").Range("A1").End(xlDown).Offset(1, 0) = pass1
            End If
        End If
    Loop Until isPasswordUnique And pass2 = pass1
 
End Sub
comments powered by Disqus

Info

Link to this snippet:


Download to Code Collector

To use the direct link to your snippet on CodeCollector.net either copy the html from the above section or drag the Download to Code Collector to where you would like to use it.

More Info:

Times Viewed: 19
Date Added: 2017-09-06 21:27:59
Last Modified: 2017-09-09 14:05:31

Web Analytics