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)
  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() &#39; demo the function!<br/> Dim r As Range, retVal, sKey As String<br/> sKey = Application.InputBox(&#34;Enter your key&#34;, &#34;Key entry&#34;, &#34;My Key&#34;, , , , , 2)<br/> retVal = MsgBox(&#34;This is the key you entered:&#34; & vbNewLine & Chr$(34) & sKey & Chr$(34) & vbNewLine & _<br/> &#34;Please confirm OK or Cancel to exit&#34;, vbOKCancel, &#34;Confirm Key&#34;)<br/> If retVal = vbCancel Then Exit Sub<br/> For Each r In Sheets(&#34;Sheet1&#34;).UsedRange<br/> If r.Interior.ColorIndex = 6 Then r.Value = XorC(r.Value, sKey)<br/> Next r<br/>End Sub

Views 2354 Downloads 701

'Encryption', 'decryption', 'xor', 'NotMyWork'

Protection VBA