Solved: Edit KB Encrypt Code

[ndendrinos]

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("B30"), 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
Call Sendmail
Call Clearing
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
Hello to all,
Above code is excellent and requires an expert to tailor it to my needs.... if possible please help.

The WB that contains this code (order form) will be sent to me by my customers.

What I hope for is to get rid of the box that requires the user to enter a "key" and the confirmation of it.

I want to be able to hard code a key of my choosing in the code ....let us say "max"
Thank you

[ndendrinos]

Well it appears that I managed to edit the code to my liking

This works for me:
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("B30"), Target) Is Nothing Then
' Process Encryption.
sKey = "max"
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
Call Clear

End Sub
BUT WHEN I ADD "call Clear" TO IT ALL HELL BRAKES LOOSE and here I need expert help big time.

Sub Clear()

Range("B30").Select
Selection.ClearContents
ActiveWorkbook.Save
ActiveWorkbook.Close False

End Sub


The clearing of the cells triggers the initial macro again & again &again ...
Thank you

[CreganTur]

BUT WHEN I ADD "call SendMail" TO IT ALL HELL BRAKES LOOSE and here I need expert help big time.
You don't need an expert here- just grab a shotgun, head deeper into the earth and kill all the hell-spawn that tries to savage you. Then, once you've found the BFG 9000, head to the lowest level, kill the big monster and close the portal to hell.

It's a simple weekend job- you should be able to handle it:rofl:


Please be specific in describing the problems you're running into- if there are error messages tell us the error number and provide the description... and tell is which line of code is highlighted when you debug. This info will help us diagnose your problem faster:thumb

[ndendrinos]

Hello CreganTur
Thank you for your reply ... I was editing while you replied so if you revisit this thread pls read my edit.
Thank you

[CreganTur]

Hello CreganTur
Thank you for your reply ... I was editing while you replied so if you revisit this thread pls read my edit.
Thank you

The reason for this is because you're using the Worksheet_Change event. This means that the code will run every time there is any change on the worksheet.

You need to use a different event, or add in some validation code so that the code won't run if the cells are cleared.

[ndendrinos]

or add in some validation code so that the code won't run if the cells are cleared.

True so need something like ... if cell "empty" then exit sub"
Can you help with this?

[CreganTur]

This is really simplistic, but maybe something like this will work for you- I set it to check the value of cell A1:



Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

If Sheet1.Range("A1").value = "" Then
Exit Sub
End If

Dim r As Range, retVal, sKey As String

On Error Goto ws_exit
Application.EnableEvents = False
If Not Intersect(Range("B30"), Target) Is Nothing Then
' Process Encryption.
sKey = "max"
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
Call Clear

End Sub

[ndendrinos]

Again you replied while I was typing.
Came up with this :
Sub Clearing()

Range("B30").Select
If ActiveCell.Value = "" Then
Exit Sub
End If
Selection.ClearContents
ActiveWorkbook.Save
ActiveWorkbook.Close False

End Sub
Simple is just about ALL I can understand ... wondering why you chose A1 instead of B30 ?
Thanks again

[ndendrinos]

I understand now , Thanks for your time. this is solved now

[mdmackillop]

Unless you have some abort code as suggested above, change the order of these lines.

Application.EnableEvents = False
If Not Intersect(Range("B30"), Target) Is Nothing Then

You do not want to disable events if the main code is not going to run.

[ndendrinos]

Perfect and suggestion adopted
Thank you mdmackillop