Encryption + Hex

[WeightOver2001]

Is there anyway using this encryption, http://www.freevbcode.com/ShowCode.asp?ID=4398, to make the output in hex form? So it encrypts it using RC4 then hexs the outputted string?

[Phil Weber]

Encrypted = RC4("This is a test.", "Password")
For I = 1 To Len(Encrypted)
    Debug.Print Hex(Asc(Mid(Encrypted, I, 1)));
Next

[WeightOver2001]

Encrypted = RC4("This is a test.", "Password")
For I = 1 To Len(Encrypted)
    Debug.Print Hex(Asc(Mid(Encrypted, I, 1)));
Next

Thats not what i am looking for. Is there some way to do it so its like this.
Encrypted = RC4("EncryptedHexedString", "Password")
So when RC4 is decrypting it it also has to first make the hexed string to byte then decrypt it via rc4?

[WeightOver2001]

any ideas?

[Ron Weller]

Actually Phil was totally on the right track. He just needed to take is a step
further with both an Encrypt and Decrypt function.
If you already have functions that perform RC4 Encrypt and Decrypt there is
no need to rewrite them, just create new functions that handle the hex
conversions and calls the original RC4 routines.

Function RC4HexEncrypt(str As String, pwd As String) As String
  Dim I As Long
  Dim enc As String
  Dim buf As String

  'call the original RC4 Encrypt Routine
  enc = RC4Encrypt(str, pwd)
  
  'convert encrypted string to hex
  For I= 1 To Len(enc)
    buf = buf & Right("0" & Hex(Ans(Mid$(enc, I, 1))), 2)
  Nex I
  
  RC4HexEncrypt = buf

End Function

Function RC4HexDecrypt(str As String, pwd As String) As String
  Dim I As Long
  Dim buf As String
  Dim dcr As String
  
  dcr = ""
  'convert the hex string to the version to be decrypted
  'if an error occurs here, it's not a hex string so bail out
  On Error Goto Done
  For I = 1 To Len(str) Step 2
    buf = buf & Chr$(CByte("&H" & Mid$(str, I, 2)))
  Next I 
  On Error Goto 0

  'call the original RC4 Decrypt routine
  dcr = RC4Decrypt(buf, pwd)

Done: 
  RC4HexDecrypt = dcr

End Function

[WeightOver2001]

Private Sub Form_Load()
Text1.Text = RC4HexEncrypt("helloworld", "409")
End Sub
Function RC4HexEncrypt(str As String, pwd As String) As String
  Dim I As Long
  Dim enc As String
  Dim buf As String

  enc = RC4Encrypt(str, pwd)
  
  For I = 1 To Len(enc)
    buf = Right("0" & Hex(Asc(Mid$(enc, I, 1))), 2)
  Next I
  
  RC4HexEncrypt = buf
End Function
Public Function RC4Encrypt(ByVal Expression As String, ByVal Password As String) As String
On Error Resume Next
Dim RB(0 To 255) As Integer, X As Long, Y As Long, Z As Long, Key() As Byte, ByteArray() As Byte, Temp As Byte
If Len(Password) = 0 Then
    Exit Function
End If
If Len(Expression) = 0 Then
    Exit Function
End If
If Len(Password) > 256 Then
    Key() = StrConv(Left$(Password, 256), vbFromUnicode)
Else
    Key() = StrConv(Password, vbFromUnicode)
End If
For X = 0 To 255
    RB(X) = X
Next X
X = 0
Y = 0
Z = 0
For X = 0 To 255
    Y = (Y + RB(X) + Key(X Mod Len(Password))) Mod 256
    Temp = RB(X)
    RB(X) = RB(Y)
    RB(Y) = Temp
Next X
X = 0
Y = 0
Z = 0
ByteArray() = StrConv(Expression, vbFromUnicode)
For X = 0 To Len(Expression)
    Y = (Y + 1) Mod 256
    Z = (Z + RB(Y)) Mod 256
    Temp = RB(Y)
    RB(Y) = RB(Z)
    RB(Z) = Temp
    ByteArray(X) = ByteArray(X) Xor (RB((RB(Y) + RB(Z)) Mod 256))
Next X
RC4 = StrConv(ByteArray, vbUnicode)
End Function

Doesn't work...

[Ron Weller]

Sorry I made some errors. pwd parameter should be a string.

Function RC4HexDecrypt(str As String, pwd As String) As String

Also when I assigned the Hex codes to buf I should have appended it, not just assign it.

buf = buf & Right("0" & Hex(Ans(Mid$(enc, I, 1))), 2)

I also checked your RC4Encrypt routine and found an error, here are the corrected routines:

Private Sub Form_Load()
  Text1.Text = RC4HexEncrypt("helloworld", "409")
End Sub

Function RC4HexEncrypt(str As String, pwd As String) As String
  Dim I As Long
  Dim enc As String
  Dim buf As String

  enc = RC4Encrypt(str, pwd)
  
  For I = 1 To Len(enc)
    buf = buf & Right("0" & hex(Asc(Mid$(enc, I, 1))), 2)
  Next I
  
  RC4HexEncrypt = buf
End Function

Public Function RC4Encrypt(ByVal Expression As String, ByVal Password As String) As String
  On Error Resume Next
  Dim RB(0 To 255) As Integer
  Dim X As Long
  Dim Y As Long
  Dim Z As Long
  Dim Key() As Byte
  Dim ByteArray() As Byte
  Dim Temp As Byte
  
  If Len(Password) = 0 Then Exit Function
  If Len(Expression) = 0 Then Exit Function
  
  Key() = StrConv(Left$(Password, 256), vbFromUnicode)
  
  For X = 0 To 255
    RB(X) = X
  Next X
  
  For X = 0 To 255
    Y = (Y + RB(X) + Key(X Mod Len(Password))) Mod 256
    Temp = RB(X)
    RB(X) = RB(Y)
    RB(Y) = Temp
  Next X
  Y = 0
  
  ByteArray() = StrConv(Expression, vbFromUnicode)
  
  For X = 0 To Len(Expression)
    Y = (Y + 1) Mod 256
    Z = (Z + RB(Y)) Mod 256
    Temp = RB(Y)
    RB(Y) = RB(Z)
    RB(Z) = Temp
    ByteArray(X) = ByteArray(X) Xor (RB((RB(Y) + RB(Z)) Mod 256))
  Next X
  
  RC4Encrypt = StrConv(ByteArray, vbUnicode)
End Function

When I ran it "helloworld", "409" encrypted to this "81AB8EE3E7E815895BD3"

[WeightOver2001]

Its not successfully decrypting it for me.

Private Sub Form_Load()
  MsgBox RC4HexEncrypt("helloworld", "409")
  MsgBox RC4HexDecrypt("81AB8EE3E7E815895BD3", "409")
End Sub
Function RC4HexDecrypt(str As String, pwd As String) As String
  Dim I As Long
  Dim buf As String
  Dim dcr As String
  
  dcr = ""
  On Error GoTo Done
  For I = 1 To Len(str) Step 2
    buf = buf & Right("0" & Hex(Asc(Mid$(enc, I, 1))), 2)
  Next I
  On Error GoTo 0

  dcr = RC4(buf, pwd)

Done:
  RC4HexDecrypt = dcr
End Function
Function RC4HexEncrypt(str As String, pwd As String) As String
  Dim I As Long
  Dim enc As String
  Dim buf As String

  enc = RC4(str, pwd)
  
  For I = 1 To Len(enc)
    buf = buf & Right("0" & Hex(Asc(Mid$(enc, I, 1))), 2)
  Next I
  
  RC4HexEncrypt = buf
End Function
Public Function RC4(ByVal Expression As String, ByVal Password As String) As String
On Error Resume Next
Dim RB(0 To 255) As Integer, X As Long, Y As Long, Z As Long, Key() As Byte, ByteArray() As Byte, Temp As Byte
If Len(Password) = 0 Then
    Exit Function
End If
If Len(Expression) = 0 Then
    Exit Function
End If
If Len(Password) > 256 Then
    Key() = StrConv(Left$(Password, 256), vbFromUnicode)
Else
    Key() = StrConv(Password, vbFromUnicode)
End If
For X = 0 To 255
    RB(X) = X
Next X
X = 0
Y = 0
Z = 0
For X = 0 To 255
    Y = (Y + RB(X) + Key(X Mod Len(Password))) Mod 256
    Temp = RB(X)
    RB(X) = RB(Y)
    RB(Y) = Temp
Next X
X = 0
Y = 0
Z = 0
ByteArray() = StrConv(Expression, vbFromUnicode)
For X = 0 To Len(Expression)
    Y = (Y + 1) Mod 256
    Z = (Z + RB(Y)) Mod 256
    Temp = RB(Y)
    RB(Y) = RB(Z)
    RB(Z) = Temp
    ByteArray(X) = ByteArray(X) Xor (RB((RB(Y) + RB(Z)) Mod 256))
Next X
RC4 = StrConv(ByteArray, vbUnicode)
End Function

And you know the original rc4 code i posted has both a encryption/decryption function all in the same function. No need for separate RC4Decrypt / RC4Encrypt

[Ron Weller]

To decrypt you must reverse the process. First convert the hex characters
back to the encrypted characters and then call RC4 to decrypt them.

The changes I made to RC4() were mostly minor optimizations they have no
effect on the end results. I had not done a detailed analysis of RC4() so I
did not realize thet it reverses itself when applied to the encrypted string.
Changing the characters back and fourth from Hex() won't work the same
way, so you will need both an Encrypt and Decrypt function.

Here is the additional Decrypt routine and I included my version of RC4(),
renamed back to just RC4(), so you can play around with it.
Some changes are just cosmetic like splitting the Dim statement into
multipule Dims. I find it easier to read and later modify the code this way.
The Left$() function returns the entire string if it's not greater that the
length parameter.
All numeric variables in VB are initialized to zero, therefore they only need to
be reset if their value was ever changed.
X is only used as a loop counter and is automatically reset by each 'For'
statement.
Z is only used in one loop so it doesn't need resetting.

Public Sub RC4HexTest()
  Debug.Print RC4HexEncrypt("helloworld", "409")
  Debug.Print RC4HexDecrypt("81AB8EE3E7E815895BD3", "409")
End Sub

Function RC4HexEncrypt(str As String, pwd As String) As String
  Dim I As Long
  Dim enc As String
  Dim buf As String

  enc = RC4(str, pwd)
  
  For I = 1 To Len(enc)
    buf = buf & Right("0" & hex(Asc(Mid$(enc, I, 1))), 2)
  Next I
  
  RC4HexEncrypt = buf
End Function

Function RC4HexDecrypt(str As String, pwd As String) As String
  Dim I As Long
  Dim enc As String
  Dim buf As String

  For I = 1 To Len(str) Step 2
    enc = enc & Chr$(CByte("&H" & Mid$(str, I, 2)))
  Next I
  
  buf = RC4(enc, pwd)
    
  RC4HexDecrypt = buf
End Function

Public Function RC4(ByVal Expression As String, ByVal Password As String) As String
  On Error Resume Next
  Dim RB(0 To 255) As Integer
  Dim X As Long
  Dim Y As Long
  Dim Z As Long
  Dim Key() As Byte
  Dim ByteArray() As Byte
  Dim Temp As Byte
  
  If Len(Password) = 0 Then Exit Function
  If Len(Expression) = 0 Then Exit Function
  
  Key() = StrConv(Left$(Password, 256), vbFromUnicode)
  
  For X = 0 To 255
    RB(X) = X
  Next X
  
  For X = 0 To 255
    Y = (Y + RB(X) + Key(X Mod Len(Password))) Mod 256
    Temp = RB(X)
    RB(X) = RB(Y)
    RB(Y) = Temp
  Next X
  Y = 0
  
  ByteArray() = StrConv(Expression, vbFromUnicode)
  
  For X = 0 To Len(Expression)
    Y = (Y + 1) Mod 256
    Z = (Z + RB(Y)) Mod 256
    Temp = RB(Y)
    RB(Y) = RB(Z)
    RB(Z) = Temp
    ByteArray(X) = ByteArray(X) Xor (RB((RB(Y) + RB(Z)) Mod 256))
  Next X
  
  RC4 = StrConv(ByteArray, vbUnicode)
  
End Function