Global Const sKey As String = "E12W2^!cH6lG2bgT" 'Sets the key
'Code for Xor function
Function XorC(ByVal sData As String, ByVal sKey As String) As String
Dim l As Long, i As Long, byIn() As Byte, byOut() As Byte, byKey() As Byte
Dim bEncOrDec As Boolean
'confirm valid string and key input:
If Len(sData) = 0 Or Len(sKey) = 0 Then XorC = "Invalid argument(s) used": Exit Function
'check whether running encryption or decryption (flagged by presence of "A^#" at start of sData):
If Left$(sData, 3) = "A^#" Then
bEncOrDec = False 'decryption
sData = Mid$(sData, 4)
Else
bEncOrDec = True 'encryption
End If
'assign strings to byte arrays (unicode)
byIn = sData
byOut = sData
byKey = sKey
l = LBound(byKey)
For i = LBound(byIn) To UBound(byIn) - 1 Step 2
byOut(i) = ((byIn(i) + Not bEncOrDec) Xor byKey(l)) - bEncOrDec 'avoid Chr$(0) by using bEncOrDec flag
l = l + 2
If l > UBound(byKey) Then l = LBound(byKey) 'ensure stay within bounds of Key
Next i
XorC = byOut
If bEncOrDec Then XorC = "A^#" & XorC 'add "A^#" onto encrypted text
End Function
'Function to update password when changed and when input to access hidden columns or sheets
Public Function sPassword(key As String)
Application.ScreenUpdating = False
With Sheets("Settings")
.Unprotect ("protection password")
sPassword = XorC(Sheets("Settings").Range("P4").Value, key)
If Left(Sheets("Settings").Range("P4").Value, 3) <> "A^#" Then Sheets("Settings").Range("P4").Value = sPassword
.Protect ("protection password")
End With
Application.ScreenUpdating = True
End Function
'Code in userform for password input
Private Sub tb_password_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
If SettingsPassword = True Then
If tb_password = sPassword(sKey) Then
PasswordOk = True
SettingsPassword = False
End If
End If
Hide
End If
End Sub
'Code for Change Password userform
Private Sub btnOK_Click()
Dim pw1, pw2, pw3 As String
pw1 = txtPw1.Text
pw2 = txtPw2.Text
pw3 = txtPw3.Text
If pw1 <> sPassword(sKey) Then
yenah = MsgBox("The current password is incorrect, please try again.", vbCritical + vbRetryCancel, "Error")
Select Case yenah: Case vbRetry: clrall: Case vbCancel: Unload Me: End Select
Else
If Len(pw2) < 6 Then
YN = MsgBox("The password needs to be more than 5 characters long.", vbExclamation + vbRetryCancel, "Error")
Select Case YN: Case vbRetry: clrn: Case vbCancel: Unload Me: End Select
Else
If pw2 <> pw3 Then
yenahbro = MsgBox("The new passwords do not match, please try again.", vbCritical + vbRetryCancel, "Error")
Select Case yenahbro: Case vbRetry: clrn: Case vbCancel: Unload Me: End Select
Else
If pw1 = pw2 Then
yenahyenah = MsgBox("The old and new passwords match, please try again.", vbExclamation + vbRetryCancel, "Error")
Select Case yenahyenah: Case vbRetry: clrn: Case vbCancel: Unload Me: End Select
Else
Application.ScreenUpdating = False
With Sheets("Settings")
.Unprotect ("protection password")
.Range("P4").Value = pw2
.Protect ("protection password")
pw3 = sPassword(sKey)
End With
wsCou = ActiveWorkbook.Worksheets.count
For i = 1 To wsCou
If ActiveWorkbook.Worksheets(i).ProtectContents = True And ActiveWorkbook.Worksheets(i).name <> "Settings" Then
ActiveWorkbook.Worksheets(i).Unprotect (pw1)
ActiveWorkbook.Worksheets(i).Protect (pw2), DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True, AllowFiltering:=True
End If
Next i
PasChgSettings.Hide
Application.ScreenUpdating = True
a = MsgBox("Password has successfully been changed from '" & pw1 & "' to '" & pw2 & "'." & vbNewLine & vbNewLine & "Please ensure the new password is remembered as resetting a forgotten password can only be achieved with assistance from the original programmers.", vbInformation, "Personnel Status Tracker - Password Change")
Unload Me
End If
End If
End If
End If
End Sub