Text Encoding

Theres a cool little excel thing here:

http://blog.livedoor.jp/andrewe/arch...at_107032.html

and I have attached my modified versions too.

Its still REALLY insecure tho...


I read about hiding your encoded message in an image file, that way people dont even know that there IS a message!

For what amounts to a surfeit, the following idyllic Function code, coutesy of Bob Bovey, does the trick:

Function  EncriptDecript(sdata as String, N as Long)
Dim bData() as Byte

bData=sData
For i = LBound(bData) to UBound(bdata)
bdata(i)=bdata(i) XOR N
Next
sData=bData

EncriptDecript=sData

End Function

'To test

Sub Test()
Dim c as Range
For each c in ActiveSheet.UsedRange
 y=EncriptDecript(c.value,178)  '-any number within 1-255 will do
c.value=y
End Sub

The first-run ecodes, the second automatically decodes to original. Bob's Code uses Octal representations of byte and transmogrifies them with XOR function.

Like all encoding/decoding utilities, it is not fool-proof as you require 255 passes in a loop to unlock the key.

For a very long time now, I have, by continual usage, found my own custom Encript/Decript code fairly reliable, if ponderous. It is again not 100% fail-safe. The codings can use both positive and negative keys, and thereby sidestep tradition. Again, a different key can be used for any one run -to take care of a single encode/decode session.

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 As Integer
Dim acsheet As Worksheet
Application.ScreenUpdating = False

'make a spare copy of text on a fresh worksheet for 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 code at very end of text
LastRw = Cells.SpecialCells(xlCellTypeLastCell).Row
Set Lastcel = Cells.SpecialCells(xlCellTypeLastCell)
Set EffectiveLastcel = Cells(LastRw, Range("iv" & LastRw).End(xlToLeft).Column)
'MsgBox EffectiveLastCel.Address

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

'provide coding seal of Chr(32)&chr(95) as first 2 characters on Line1 to prevent re-encrypting and confusing code numbering
FirstCel.Value = Chr(32) & Chr(95) & FirstCel.Value
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

'Code automatically detects the ecrpting code 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 Decrept a normal text." & vbCrLf & "You may have to encrpit before decripting", vbInformation: Exit Sub
'remove encript seal of Chr(32)& Chr(95) at beginning
FirstCel.Value = Mid(FirstCel.Value, 3, Len(FirstCel.Value) - 2)
'Detect 3-digit encrypting code
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))
'MsgBox cd
'delete 2-digit encripting code appended as 00XX
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
'restoring reverse text to normal
 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