PDA

View Full Version : Solved: ENCRYPTS



ndendrinos
10-13-2008, 04:19 PM
Sub test()
'this sub is only present to demonstrate use of the function!
'it is not required to use 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)
End If
Next r
End Sub
I need help in adapting above by Richard Schollar/mdmackillop like this:

After the customer has filled the details of his credit card number [D48] and by a change event of that one cell (no need for a Command Button) the routine runs and encrypts the number.

I would like to delete the part that runs the code on "yellowed" cells .... rather restrict it to cell D48

If possible I will then try to add further code to the routine to kill the routine itself in the VBA editor and save the file.

My goal: The customer emails me his order with his credit card encrypted... I copy/paste Sheet1 in MY COPY (routine and all including color fill) fill D48 in yellow , click the command button and decrypt the credit card number knowing the password used by the customer.



Many thanks

Demosthine
10-13-2008, 09:43 PM
Good Evening.

The easy solution is to use the Worksheet_Change Event, which will run every time a cell is changed. Something as simple pressing the Delete button on an empty cell will cause this Event to execute.

The key to processing it currectly is to execute it only if the certain cell is the one that was changed. For this, the Worksheet_Change Event has a Target Argument.

There are two ways to do this. The first is a simple use of the Address Property.


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "D48" Then
' Process Encryption.
End If
End Sub


or


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("D48"), Target) Is Nothing Then
' Process Encryption.
MsgBox "Processing Encryption."
Else
' Ignore the Change.
End If
End Sub



Check out the Knowledge Base and you should find an article on how to execute a Run-Once Function that will delete the appropriate Module once it's complete. If you don't find it by tomorrow afternoon, I'll post a link directly to it. I don't have that info handy at the moment.

Scott

ndendrinos
10-14-2008, 08:04 AM
Hello Scott.
Tried these before posting and failed
Here is the file maybe you can identify the problem.
Thank you

Bob Phillips
10-14-2008, 08:34 AM
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, retVal, sKey As String

On Error GoTo ws_exit
Application.EnableEvents = False
If Not Intersect(Range("D48"), Target) Is Nothing Then
' Process Encryption.
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)
End If
Next r
End If

ws_exit:
Application.EnableEvents = True
End Sub

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

ndendrinos
10-14-2008, 09:02 AM
Thank you XLD .. now works perfect