Help with Encryption Code

[Gregm66]

Hi all,

Im not sure how this code works completely i found it using google, there is 3 different parts to it. 1st part is a Private Function as is the 2nd Part, The last part is just a Sub..

The code all works fine and does exactly what it is ment to do Encrypt Alphnumeric and special characters. My Question is,

Is it at all possible in the code below to have the encryption run without showing 3 input box's?... i would like it to just take the number in a given cell and automatically encrypt it to an adjacent cell, without the user knowing.. see code below..

Sub EncryptionRange()
    Dim xRg As Range
    Dim xPsd As String
    Dim xTxt As String
    Dim xEnc As Boolean
    Dim xRet As Variant
    Dim xCell As Range
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("O1:", "O3", xTxt, , , , , 8) ' Shows an inputbox
    Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
    If xRg Is Nothing Then Exit Sub
    xPsd = InputBox("Enter Password:") ' Shows an input box
    If xPsd = "" Then
        MsgBox "Password cannot be empty"
        Exit Sub
    End If
    xRet = Application.InputBox("Type 1 to encrypt cell(s);Type 2 to decrypt cell(s)", "Number", , , , , , 1)' Shows an input box
    If TypeName(xRet) = "Boolean" Then Exit Sub
    If xRet > 0 Then
        xEnc = (xRet Mod 2 = 1)
        For Each xCell In xRg
            If xCell.Value <> "" Then
                xCell.Value = Encryption(xPsd, xCell.Value, xEnc)
            End If
        Next
    End If
End Sub

Thanks in advance for any help

 

[Logit]

THIS LINE:

xPsd = InputBox("Enter Password:") ' Shows an input box

can be changed to: xPsd = "Password"  '<--- password can be anything


THIS LINE :


    xRet = Application.InputBox("Type 1 to encrypt cell(s);Type 2 to decrypt cell(s)", "Number", , , , , , 1) ' Shows an input box

can be changed to : "1"

Also ... the DIM statement : Dim xRet As Variant
may need to be changed to Dim xRet As Integer or the xRet = may need to be changed
to"

xRet = 1

(not surrounded in quotation marks).

Also, I receive an error here on this line : Encryption(xPsd, xCell.Value, xEnc)

Specifically on the term Encryption ... is there more to this code you haven't posted ? Or what is the URL where you obtained it ?

 

[Michael M]

You could use a cell reference for this line and put either 1 or 2 in the cell
from this

xRet = Application.InputBox("Type 1 to encrypt cell(s);Type 2 to decrypt cell(s)", "Number", , , , , , 1)

to this

xRet = Range("A1").value

If you don't need a password, remove this

xPsd = InputBox("Enter Password:") ' Shows an input box
    If xPsd = "" Then
        MsgBox "Password cannot be empty"
        Exit Sub
    End If

But I don't know what the first InputBox actually calls for !!

 

[Gregm66]

Thanks for your reply Logit,

Please see the rest of the code below..

Public Function Encryption(ByVal Psd As String, ByVal InTxt As String, Optional ByVal Enc As Boolean = True) As String
    Dim xOffset As Long
    Dim xLen As Integer
    Dim I As Integer
    Dim xCh As Integer
    Dim xOutTxt As String
    xOffset = StrToPsd(Psd)
    Rnd -1
    Randomize xOffset
    xLen = Len(InTxt)
    For I = 1 To xLen
        xCh = Asc(Mid$(InTxt, I, 1))
        If xCh >= 32 And xCh <= 126 Then
            xCh = xCh - 32
            xOffset = Int((96) * Rnd)
            If Enc Then
                xCh = ((xCh + xOffset) Mod 95)
            Else
                xCh = ((xCh - xOffset) Mod 95)
                If xCh < 0 Then xCh = xCh + 95
            End If
            xCh = xCh + 32
            xOutTxt = xOutTxt & Chr$(xCh)
        End If
    Next I
    Encryption = xOutTxt
End Function

Public Function StrToPsd(ByVal Txt As String) As Long
'Encryption
    Dim xVal As Long
    Dim xCh As Long
    Dim xSft1 As Long
    Dim xSft2 As Long
    Dim I As Integer
    Dim xLen As Integer
    xLen = Len(Txt)
    For I = 1 To xLen
        xCh = Asc(Mid$(Txt, I, 1))
        xVal = xVal Xor (xCh * 2 ^ xSft1)
        xVal = xVal Xor (xCh * 2 ^ xSft2)
        xSft1 = (xSft1 + 7) Mod 19
        xSft2 = (xSft2 + 13) Mod 23
    Next I
    StrToPsd = xVal
End Function

 

[Gregm66]

The first input box calls for the cell to be encrypted.. on the first inputbox open i select the cell to encrypt

 

[Gregm66]

Thanks for your help Logit and Michael M,

I got it sorted,, The first input box as i said was for the cell to be encrypted.
I changed that line to:

Set xRg = Range("O2")

Now it does it all automatically without user knowing..

Thanks again heaps for all your help

 

[Logit]

.
Glad you have it working.

Thanks for remainder of code.