Homework_3 Password Encyrption Clear

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

Code for Snippet:

                
Option Explicit
'*************************************************************************************************************
'Write your solution inside each appropriate and relevant Sub below
'Use good programming practices as discussed in class: Comments, indentations, ...
'To run a particular Sub, place the cursor anywhere inside the Sub, and hit the Green Triangle icon at the top
'*************************************************************************************************************
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
 
Sub Scramble()
    'CASE: Encryption Application
 
    Dim myMessage, char As String
    Dim lengthMsg, position As Integer
    Dim e As Integer
    Dim encryptMsg As String
 
    Do
        myMessage = InputBox("Enter your message.")
        lengthMsg = Len(myMessage)
        Range("J5").Value = myMessage
 
    Loop Until lengthMsg > 0
 
    encryptMsg = ""
    For position = 1 To lengthMsg
        char = Mid(myMessage, position, 1)
 
        ' Scramble message
 
        If UCase(char) >= "A" And UCase(char) <= "Z" Then
            For e = 1 To 52
                If Range("A3").Offset(e, 0).Value = char Then
                    encryptMsg = encryptMsg & Range("A3").Offset(e, 1).Value
                    Exit For
                End If
            Next
        Else
            encryptMsg = encryptMsg & char
        End If
    Next
 
    MsgBox "The scrambled message is:" & vbCrLf & vbCrLf & _
        encryptMsg, vbInformation, "Scrambled"
    Range("J11").Value = encryptMsg
End Sub
 
Sub Unscramble()
    Dim encryptMsg, char As String
    Dim lengthMsg, position As Integer
    Dim d As Integer
    Dim decryptMsg As String
 
    Do
        encryptMsg = InputBox("Enter the scrambled message.")
        lengthMsg = Len(encryptMsg)
    Loop Until lengthMsg > 0
 
    decryptMsg = ""
    For position = 1 To lengthMsg
        char = Mid(encryptMsg, position, 1)
        If UCase(char) >= "A" And UCase(char) <= "Z" Then
            For d = 1 To 52
                If Range("A3").Offset(d, 1).Value = char Then
                    decryptMsg = decryptMsg & Range("A3").Offset(d, 0).Value
                    Exit For
                End If
            Next
        Else
            decryptMsg = decryptMsg & char
        End If
    Next
    MsgBox "Your unscrambled message is:" & vbCrLf & vbCrLf & _
        decryptMsg, vbInformation, "Unscrambled"
    Range("J13").Value = decryptMsg
End Sub
 
Sub Clear()
 
Worksheets("Encryption").Range("J5:J13").ClearContents
 
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: 7
Date Added: 2017-09-06 16:35:30
Last Modified: 2017-09-09 14:05:31

Web Analytics