Simple small function to Encrypt or Decrypt a string in cell
Test_XorC is for testing the function, test is in VBA-Excel, but XorC can be used in all VBA platforms
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 "xxx" at start of sData):
If Left$(sData, 3) = "xxx" 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 = "xxx" & XorC 'add "xxx" onto encrypted text
End Function
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 "xxx" at start of sData):
If Left$(sData, 3) = "xxx" 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 = "xxx" & XorC 'add "xxx" onto encrypted text
End Function
sData, sKey
Sub Test_XorC() ' demo the function!
Dim r As Range, retVal, sKey As String
sKey = Application.InputBox("Enter your key", "Key entry", "My Key", , , , , 2)
retVal = MsgBox("This is the key you entered:" & vbNewLine & Chr$(34) & sKey & Chr$(34) & vbNewLine & _
"Please confirm OK or Cancel to exit", vbOKCancel, "Confirm Key")
If retVal = vbCancel Then Exit Sub
For Each r In Sheets("Sheet1").UsedRange
If r.Interior.ColorIndex = 6 Then r.Value = XorC(r.Value, sKey)
Next r
End Sub
Dim r As Range, retVal, sKey As String
sKey = Application.InputBox("Enter your key", "Key entry", "My Key", , , , , 2)
retVal = MsgBox("This is the key you entered:" & vbNewLine & Chr$(34) & sKey & Chr$(34) & vbNewLine & _
"Please confirm OK or Cancel to exit", vbOKCancel, "Confirm Key")
If retVal = vbCancel Then Exit Sub
For Each r In Sheets("Sheet1").UsedRange
If r.Interior.ColorIndex = 6 Then r.Value = XorC(r.Value, sKey)
Next r
End Sub
Views 4,996
Downloads 1,419
CodeID
DB ID
ANmarAmdeen
606
Revisions
v1.0
Sunday
July
1
2018
