Please Help! Encryption problem

[rdcody]

Hey All,

I found the following encrypt/decrypt code below somewhere.

Public Function EncryptString(ByVal InString As String, ByVal EncryptKey As String) As String
 Dim TempKey, OutString As String
 Dim OldChar, NewChar, CryptChar As Long
 Dim i As Integer
 
 ' Initilize i and make sure the EncryptKey is long enough
 i = 0
 Do
  TempKey = TempKey + EncryptKey
 Loop While Len(TempKey) < Len(InString)
 
 ' Loop through the string to encrypt each character.
 Do
  i = i + 1
  OldChar = Asc(Mid(InString, i, 1))
  CryptChar = Asc(Mid(TempKey, i, 1))
  ' If it's an even character, add the ASCII value of the
  ' appropriate character in the Key, otherwise, subract it.
  ' Also, make sure the value is between 0 and 127.
  Select Case i Mod 2
   Case 0      'Even Character
    NewChar = OldChar + CryptChar
    If NewChar > 127 Then NewChar = NewChar - 127
   Case Else   'Odd Character
    NewChar = OldChar - CryptChar
    If NewChar < 0 Then NewChar = NewChar + 127
  End Select
  ' If the value is less than 35, add 40 to it (to make sure
  ' it's in the display range) and put it in an escape
  ' sequence (using ! [ASCII Value 33] as the escape char)
  If NewChar < 35 Then
   OutString = OutString + "!" + Chr(NewChar + 40)
  Else
   OutString = OutString + Chr(NewChar)
  End If
 Loop Until i = Len(InString)
 
 EncryptString = OutString

End Function

Public Function DecryptString(ByVal InString As String, ByVal EncryptKey As String) As String
 Dim TempKey, OutString As String
 Dim OldChar, NewChar, CryptChar As Long
 Dim i, c As Integer
 
 ' Initialize c and i (loop variables)
 c = 0       ' c is used for InString
 i = 0       ' i is used for EncryptKey
 ' Make sure the EncryptKey is long enough
 Do
  TempKey = TempKey + EncryptKey
 Loop While Len(TempKey) < Len(InString)
 
 Do
  ' In the decrypt function, two integers are need keeping
  ' track of location (becuase the escape sequence it two
  ' chars long, but only has one placeholder in the key)
  i = i + 1
  c = c + 1
  OldChar = Asc(Mid(InString, c, 1))
  ' If this is an escape sequence, get the next character and
  ' subtract 40 from it's value.
  If OldChar = 33 Then
   c = c + 1
   OldChar = Asc(Mid(InString, c, 1))
   OldChar = OldChar - 40
  End If
  CryptChar = Asc(Mid(TempKey, i, 1))
  ' If it's an even character, subract the appropriate key
  ' value... also, if it's out of range, bring it back in.
  Select Case i Mod 2
   Case 0      'Even Character
    NewChar = OldChar - CryptChar
    If NewChar < 0 Then NewChar = NewChar + 127
   Case Else   'Odd Character
    NewChar = OldChar + CryptChar
    If NewChar > 127 Then NewChar = NewChar - 127
  End Select
  OutString = OutString + Chr(NewChar)
 Loop Until c = Len(InString)
 
 DecryptString = OutString

End Function

Now, this code works very well, but I have a problem...

I need to encrypt a string, and place it on a webpage for an
unlock code. If the encrypted string (using the code above)
has any brackets{} or arrow<> symbols in it, then the the HTML
code thinks it is part of the HTML structural code for the web page
and therefore, will not show it.

Would someone please show me how to fix this?

What I would really like is an encrytp/decrypt code that only uses
the following characters...

ABCDEFGHIJKLMNOPQRSTUVWXYZ
abcdefghijklmnopqrstuvwxyz
0123456789

Also, it needs to use an encrypt key.

Thanks in advance for your help,
Ron

[ranma_at]

When i use encryption, and i did it alot i always used a HEX output to store the encryption. So you dont get those weird outputs...
like for this :

http://www.planet-source-code.com/vb...41006&lngWId=1

here the HEX code:

Option Explicit   
 
Private m_InitHex as Boolean   
Private m_ByteToHex(0 To 255, 0 To 1) as Byte   
Private m_HexToByte(48 To 70, 48 To 70) as Byte   
 
Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (Destination as Any, ByVal Length as Long, ByVal Fill as Byte)   
 
Function HexToStr(HexText as String, Optional ByVal Separators as Long = 1) as String   
 
  Dim a as Long   
  Dim Pos as Long   
  Dim PosAdd as Long   
  Dim ByteSize as Long   
  Dim HexByte() as Byte   
  Dim ByteArray() as Byte   
 
  'Initialize the hex routine
  If (Not m_InitHex) Then Call InitHex   
 
  'The destination string is half
  'the size of the source string
  'when the separators are removed
  If (Len(HexText) = 2) Then   
    ByteSize = 1   
  Else   
    ByteSize = ((Len(HexText) + 1) \ (2 + Separators))   
  End If   
  ReDim ByteArray(0 To ByteSize - 1)   
 
  'Convert every HEX code to the
  'equivalent ASCII character
  PosAdd = 2 + Separators   
  HexByte() = StrConv(HexText, vbFromUnicode)   
  For a = 0 To (ByteSize - 1)   
    ByteArray(a) = m_HexToByte(HexByte(Pos), HexByte(Pos + 1))   
    Pos = Pos + PosAdd   
  Next   
 
  'Now finally convert the byte
  'array to the return string
  HexToStr = StrConv(ByteArray, vbUnicode)   
 
End Function   
Private Sub InitHex()   
 
  Dim a as Long   
  Dim b as Long   
  Dim HexBytes() as Byte   
  Dim HexString as String   
 
  'The routine is initialized
  m_InitHex = True   
 
  'Create a string with all hex values
  HexString = String$(512, "0")   
  For a = 1 To 255   
    Mid$(HexString, 1 + a * 2 + -(a < 16)) = Hex(a)   
  Next   
  HexBytes = StrConv(HexString, vbFromUnicode)   
 
  'Create the Str->Hex array
  For a = 0 To 255   
    m_ByteToHex(a, 0) = HexBytes(a * 2)   
    m_ByteToHex(a, 1) = HexBytes(a * 2 + 1)   
  Next   
 
  'Create the Str->Hex array
  For a = 0 To 255   
    m_HexToByte(m_ByteToHex(a, 0), m_ByteToHex(a, 1)) = a   
  Next   
 
End Sub   
Function StrToHex(text as String, Optional Separator as String = " ") as String   
 
  Dim a as Long   
  Dim Pos as Long   
  Dim Char as Byte   
  Dim PosAdd as Long   
  Dim ByteSize as Long   
  Dim ByteArray() as Byte   
  Dim ByteReturn() as Byte   
  Dim SeparatorLen as Long   
  Dim SeparatorChar as Byte   
 
  'Initialize the hex routine
  If (Not m_InitHex) Then Call InitHex   
 
  'Initialize variables
  SeparatorLen = Len(Separator)   
 
  'Create the destination bytearray, this
  'will be converted to a string later
  ByteSize = (Len(text) * 2 + (Len(text) - 1) * SeparatorLen)   
  ReDim ByteReturn(ByteSize - 1)   
  Call FillMemory(ByteReturn(0), ByteSize, Asc(Separator))   
 
  'We convert the source string into a
  'byte array to speed this up a tad
  ByteArray() = StrConv(text, vbFromUnicode)   
 
  'Now convert every character to
  'it's equivalent HEX code
  PosAdd = 2 + SeparatorLen   
  For a = 0 To (Len(text) - 1)   
    ByteReturn(Pos) = m_ByteToHex(ByteArray(a), 0)   
    ByteReturn(Pos + 1) = m_ByteToHex(ByteArray(a), 1)   
    Pos = Pos + PosAdd   
  Next   
 
  'Convert the bytearray to a string
  StrToHex = StrConv(ByteReturn(), vbUnicode)   
 
End Function