I faced the exigencies of needing a code that can encript a text (and
another to decript same if need be). The following twin codes are
what I came up with. They may not be the most elegant, technically
speaking, but they do the job.

Public FirstCel As Range
Sub AutoENCRIPT()
Dim num, i%, k$, m$, p$, r$
Dim c As Range, ct As String
Dim LastRw As Long
Dim EffectiveLastcel As Range
Dim FirstRw As Long
Dim FirstCol%
Dim acsheet As Worksheet
Application.ScreenUpdating = False

'make a spare copy of text on a fresh worksheet as backup
Set acsheet = ActiveSheet
Application.DisplayAlerts = False
On Error Resume Next 'if there a sheet named AutoSpareText
Worksheets("AutoSpareText").Delete
Worksheets.Add.Name = "AutoSpareText"
acsheet.Select
ActiveSheet.UsedRange.Copy Sheets("AutoSpareText").Range("A1")

'detect if encripting has ever been run
FirstRw = ActiveSheet.UsedRange.Row
FirstCol = ActiveSheet.UsedRange.Column
Set FirstCel = Cells(FirstRw, FirstCol)

If Mid(FirstCel.Value, 1, 2) = Chr(32) & Chr(95) Then MsgBox "Text has
already been encripted" & vbCrLf & "Run the Decript code",
vbInformation: Exit Sub
Randomize
Rnum = Choose(Int(1 + Rnd * 2), Int(1 + Rnd * 29) * -1, Int(1 + Rnd *
134))
num = InputBox("Enter encripting code: -29 to 134", Default:=Rnum)
If num = "" Then Exit Sub
If num 134 Or num < -29 Then Exit Sub
'reverse text
On Error Resume Next
For Each c In ActiveSheet.UsedRange
ct = Application.Trim(c)
For i = Len(ct) To 1 Step -1
k = k & Mid(ct, i, 1)
Next
c.Value = k
k = ""
Next c
'change characters into asci numbers
For Each c In ActiveSheet.UsedRange
For i = 1 To Len(c)
m = m & num + Asc(Mid(c, i, 1)) & Chr(32)
Next
c.Value = m
m = ""
Next c
'EncriptTextNumbers()
For Each c In ActiveSheet.UsedRange
For i = 1 To Len(c)
If Mid(c, i, 1) < Chr(32) Then
p = p & Mid(c, i, 1)
Else
r = r & Chr(p)
p = ""
End If
Next
c.Value = r
r = ""
Next c
'append encrypting cypher at end of text
LastRw = Cells.SpecialCells(xlCellTypeLastCell).Row
Set Lastcel = Cells.SpecialCells(xlCellTypeLastCell)
Set EffectiveLastcel = Cells(LastRw, Range("iv" &
LastRw).End(xlToLeft).Column)

If num 0 And Len(num) = 1 Then
EffectiveLastcel.Value = EffectiveLastcel.Value & "000" & num
ElseIf num 0 And Len(num) = 2 Then
EffectiveLastcel.Value = EffectiveLastcel.Value & "00" & num
ElseIf num 0 And Len(num) = 3 Then
EffectiveLastcel.Value = EffectiveLastcel.Value & "0" & num
ElseIf num < 0 And Len(num) = 2 Then
EffectiveLastcel.Value = EffectiveLastcel.Value & "-" & "00" &
Abs(Val(num))
ElseIf num < 0 And Len(num) = 3 Then
EffectiveLastcel.Value = EffectiveLastcel.Value & "-" & "0" &
Abs(Val(num))
End If
'Camouflage encripted 4-digit number by coloring font white
EffectiveLastcel.Characters(Len(EffectiveLastcel.V alue) - 4 + 1,
4).Font.Color = vbWhite

'provide coding seal of Chr(32)&chr(95) as first 2 characters on Line1
to prevent 're-encrypting
FirstCel.Value = Chr(32) & Chr(95) & FirstCel.Value
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
-------------------------------------------------------------------------------------------------
'Code automatically detects the encrpting cypher and uses it
Sub AutoDECRIPT()
Dim cd%, q$, y$, i%, k$
Dim c As Range
Dim LastRw As Long, FirstCol%
Dim EffectiveLastcel As Range
Dim Lastcel As Range
Application.ScreenUpdating = False

If Mid(FirstCel.Value, 1, 2) < Chr(32) & Chr(95) Then MsgBox "You
cannot attempt to Decript a normal text." & vbCrLf & "You may have to
encrpit before decripting", vbInformation: Exit Sub
FirstCel.Value = Mid(FirstCel.Value, 3, Len(FirstCel.Value) - 2)
LastRw = ActiveSheet.UsedRange.Rows.Count
Set Lastcel = Cells.SpecialCells(xlCellTypeLastCell)
Set EffectiveLastcel = Cells(LastRw, Range("iv" &
LastRw).End(xlToLeft).Column)
cd = Val(Right(EffectiveLastcel, 4))
q = Left(EffectiveLastcel, Len(EffectiveLastcel) - 4)
EffectiveLastcel.Value = q
For Each c In ActiveSheet.UsedRange
For i = 1 To Len(c)
y = y & Chr(Asc(Mid(c, i, 1)) - cd)
Next
c.Value = y
y = ""
Next c
For Each c In ActiveSheet.UsedRange
For i = Len(c) To 1 Step -1
k = k & Mid(c, i, 1)
Next
c.Value = k
k = ""
Next c
Application.ScreenUpdating = True
End Sub


--
davidm
------------------------------------------------------------------------
davidm's Profile: http://www.excelforum.com/member.php...o&userid=20645
View this thread: http://www.excelforum.com/showthread...hreadid=388757

David,
What about non-ASCII characters ?

NickHK

"davidm" wrote in
message ...

I faced the exigencies of needing a code that can encript a text (and
another to decript same if need be). The following twin codes are
what I came up with. They may not be the most elegant, technically
speaking, but they do the job.

Public FirstCel As Range
Sub AutoENCRIPT()
Dim num, i%, k$, m$, p$, r$
Dim c As Range, ct As String
Dim LastRw As Long
Dim EffectiveLastcel As Range
Dim FirstRw As Long
Dim FirstCol%
Dim acsheet As Worksheet
Application.ScreenUpdating = False

'make a spare copy of text on a fresh worksheet as backup
Set acsheet = ActiveSheet
Application.DisplayAlerts = False
On Error Resume Next 'if there a sheet named AutoSpareText
Worksheets("AutoSpareText").Delete
Worksheets.Add.Name = "AutoSpareText"
acsheet.Select
ActiveSheet.UsedRange.Copy Sheets("AutoSpareText").Range("A1")

'detect if encripting has ever been run
FirstRw = ActiveSheet.UsedRange.Row
FirstCol = ActiveSheet.UsedRange.Column
Set FirstCel = Cells(FirstRw, FirstCol)

If Mid(FirstCel.Value, 1, 2) = Chr(32) & Chr(95) Then MsgBox "Text has
already been encripted" & vbCrLf & "Run the Decript code",
vbInformation: Exit Sub
Randomize
Rnum = Choose(Int(1 + Rnd * 2), Int(1 + Rnd * 29) * -1, Int(1 + Rnd *
134))
num = InputBox("Enter encripting code: -29 to 134", Default:=Rnum)
If num = "" Then Exit Sub
If num 134 Or num < -29 Then Exit Sub
'reverse text
On Error Resume Next
For Each c In ActiveSheet.UsedRange
ct = Application.Trim(c)
For i = Len(ct) To 1 Step -1
k = k & Mid(ct, i, 1)
Next
c.Value = k
k = ""
Next c
'change characters into asci numbers
For Each c In ActiveSheet.UsedRange
For i = 1 To Len(c)
m = m & num + Asc(Mid(c, i, 1)) & Chr(32)
Next
c.Value = m
m = ""
Next c
'EncriptTextNumbers()
For Each c In ActiveSheet.UsedRange
For i = 1 To Len(c)
If Mid(c, i, 1) < Chr(32) Then
p = p & Mid(c, i, 1)
Else
r = r & Chr(p)
p = ""
End If
Next
c.Value = r
r = ""
Next c
'append encrypting cypher at end of text
LastRw = Cells.SpecialCells(xlCellTypeLastCell).Row
Set Lastcel = Cells.SpecialCells(xlCellTypeLastCell)
Set EffectiveLastcel = Cells(LastRw, Range("iv" &
LastRw).End(xlToLeft).Column)

If num 0 And Len(num) = 1 Then
EffectiveLastcel.Value = EffectiveLastcel.Value & "000" & num
ElseIf num 0 And Len(num) = 2 Then
EffectiveLastcel.Value = EffectiveLastcel.Value & "00" & num
ElseIf num 0 And Len(num) = 3 Then
EffectiveLastcel.Value = EffectiveLastcel.Value & "0" & num
ElseIf num < 0 And Len(num) = 2 Then
EffectiveLastcel.Value = EffectiveLastcel.Value & "-" & "00" &
Abs(Val(num))
ElseIf num < 0 And Len(num) = 3 Then
EffectiveLastcel.Value = EffectiveLastcel.Value & "-" & "0" &
Abs(Val(num))
End If
'Camouflage encripted 4-digit number by coloring font white
EffectiveLastcel.Characters(Len(EffectiveLastcel.V alue) - 4 + 1,
4).Font.Color = vbWhite

'provide coding seal of Chr(32)&chr(95) as first 2 characters on Line1
to prevent 're-encrypting
FirstCel.Value = Chr(32) & Chr(95) & FirstCel.Value
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
--------------------------------------------------------------------------
-----------------------
'Code automatically detects the encrpting cypher and uses it
Sub AutoDECRIPT()
Dim cd%, q$, y$, i%, k$
Dim c As Range
Dim LastRw As Long, FirstCol%
Dim EffectiveLastcel As Range
Dim Lastcel As Range
Application.ScreenUpdating = False

If Mid(FirstCel.Value, 1, 2) < Chr(32) & Chr(95) Then MsgBox "You
cannot attempt to Decript a normal text." & vbCrLf & "You may have to
encrpit before decripting", vbInformation: Exit Sub
FirstCel.Value = Mid(FirstCel.Value, 3, Len(FirstCel.Value) - 2)
LastRw = ActiveSheet.UsedRange.Rows.Count
Set Lastcel = Cells.SpecialCells(xlCellTypeLastCell)
Set EffectiveLastcel = Cells(LastRw, Range("iv" &
LastRw).End(xlToLeft).Column)
cd = Val(Right(EffectiveLastcel, 4))
q = Left(EffectiveLastcel, Len(EffectiveLastcel) - 4)
EffectiveLastcel.Value = q
For Each c In ActiveSheet.UsedRange
For i = 1 To Len(c)
y = y & Chr(Asc(Mid(c, i, 1)) - cd)
Next
c.Value = y
y = ""
Next c
For Each c In ActiveSheet.UsedRange
For i = Len(c) To 1 Step -1
k = k & Mid(c, i, 1)
Next
c.Value = k
k = ""
Next c
Application.ScreenUpdating = True
End Sub


--
davidm
------------------------------------------------------------------------
davidm's Profile:
http://www.excelforum.com/member.php...o&userid=20645
View this thread: http://www.excelforum.com/showthread...hreadid=388757