VB6 encrypt text using password - string

Question

Looking for a simple text encryption/decryption VB6 code. Ideally, the solution should accept (text, password) arguments and produce readable output (without any special characters), so it can be used anywhere without encoding issues.
There are lots of code available for .NET, but not really much I can find for legacy VB6. Only this I've found so far: http://www.devx.com/vb2themax/Tip/19211

Answer 1

I'm using RC4 implementation like this
Option Explicit
Private Sub Command1_Click()
Dim sSecret As String
sSecret = ToHexDump(CryptRC4("a message here", "password"))
Debug.Print sSecret
Debug.Print CryptRC4(FromHexDump(sSecret), "password")
End Sub
Public Function CryptRC4(sText As String, sKey As String) As String
Dim baS(0 To 255) As Byte
Dim baK(0 To 255) As Byte
Dim bytSwap As Byte
Dim lI As Long
Dim lJ As Long
Dim lIdx As Long
For lIdx = 0 To 255
baS(lIdx) = lIdx
baK(lIdx) = Asc(Mid$(sKey, 1 + (lIdx Mod Len(sKey)), 1))
Next
For lI = 0 To 255
lJ = (lJ + baS(lI) + baK(lI)) Mod 256
bytSwap = baS(lI)
baS(lI) = baS(lJ)
baS(lJ) = bytSwap
Next
lI = 0
lJ = 0
For lIdx = 1 To Len(sText)
lI = (lI + 1) Mod 256
lJ = (lJ + baS(lI)) Mod 256
bytSwap = baS(lI)
baS(lI) = baS(lJ)
baS(lJ) = bytSwap
CryptRC4 = CryptRC4 & Chr$((pvCryptXor(baS((CLng(baS(lI)) + baS(lJ)) Mod 256), Asc(Mid$(sText, lIdx, 1)))))
Next
End Function
Private Function pvCryptXor(ByVal lI As Long, ByVal lJ As Long) As Long
If lI = lJ Then
pvCryptXor = lJ
Else
pvCryptXor = lI Xor lJ
End If
End Function
Public Function ToHexDump(sText As String) As String
Dim lIdx As Long
For lIdx = 1 To Len(sText)
ToHexDump = ToHexDump & Right$("0" & Hex(Asc(Mid(sText, lIdx, 1))), 2)
Next
End Function
Public Function FromHexDump(sText As String) As String
Dim lIdx As Long
For lIdx = 1 To Len(sText) Step 2
FromHexDump = FromHexDump & Chr$(CLng("&H" & Mid(sText, lIdx, 2)))
Next
End Function
Command1 outputs this:
9ED5556B3F4DD5C90471C319402E
a message here
You might need better error handling on FromHexDump though.
Update (2018-05-04)
For much stronger AES 256-bit encryption (in ECB mode) and proper handling of unicode texts/passwords you can check out Simple AES 256-bit password protected encryption as implemented in mdAesEcb.bas module (~380 LOC).

Answer 2

MD5sum the the text and password together as a one way hash (and then to check, you encrypt again and compare with the stored hash. (This won't work if you MUST decrypt it again though)

Answer 3

Here's my encryption class. I use several constants to define the encryption key because in my mind it's a little more secure from someone trying to decompile the code to find it. Cryptography isn't my thing so maybe I'm kidding myself. Anyway, I used this class in an ActiveX dll called from other programs to do encryption and the reverse in a separate dll for decryption. I did it this way so people who shouldn't be seeing encrypted data don't even have the dll to do the decrypting. Change the key constants to what you want (5 long). I use a mix including unprintable characters and it has worked well for me so far. The CAPICOM is part of Windows® so you don't have to distribute.
Option Explicit
Private m_oENData As CAPICOM.EncryptedData
'combine these constants to build the encryption key
Private Const KEY1 = "12345"
Private Const KEY2 = "67890"
Private Const KEY3 = "abcde"
Private Const KEY4 = "fghij"
Private Const KEY5 = "klmno"
Private Sub Class_Initialize()
On Error Resume Next
Set m_oENData = New CAPICOM.EncryptedData
If Err.Number <> 0 Then
If Err.Number = 429 Then
Err.Raise Err.Number, App.EXEName, "Failed to create the capi com object. " & _
"Check that the capicom.dll file is installed and properly registered."
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End If
End Sub
Private Sub Class_Terminate()
Set m_oENData = Nothing
End Sub
Public Function EncryptAsBase64(ByVal RawString As String) As String
EncryptAsBase64 = Encrypt(RawString, CAPICOM_ENCODE_BASE64)
End Function
Public Function EncryptAsBinary(ByVal RawString As String) As String
EncryptAsBinary = Encrypt(RawString, CAPICOM_ENCODE_BINARY)
End Function
Private Function Encrypt(ByVal s As String, ByVal EncryptionType As CAPICOM.CAPICOM_ENCODING_TYPE) As String
Dim oEN As New CAPICOM.EncryptedData
Dim intENCType As CAPICOM.CAPICOM_ENCRYPTION_ALGORITHM
Dim strSecret As String
Dim intTries As Integer
On Error GoTo errEncrypt
intENCType = CAPICOM_ENCRYPTION_ALGORITHM_AES ' try this first and fall back if not supported
With oEN
startEncryption:
.Algorithm = intENCType
strSecret = KEY2 & KEY5 & KEY4 & KEY1 & KEY3
.SetSecret strSecret
strSecret = ""
.Content = s
' the first encryption type needs to be base64 as the .content property
' can loose information if I try to manipulate a binary string
.Content = StrReverse(.Encrypt(CAPICOM_ENCODE_BASE64))
strSecret = KEY1 & KEY4 & KEY3 & KEY2 & KEY5
.SetSecret strSecret
strSecret = ""
Encrypt = .Encrypt(EncryptionType)
End With
Set oEN = Nothing
Exit Function
errEncrypt:
If Err.Number = -2138568448 Then
' if this is the first time the step the encryption back and try again
If intTries < 1 Then
intTries = intTries + 1
intENCType = CAPICOM_ENCRYPTION_ALGORITHM_3DES
Resume startEncryption
End If
End If
Err.Raise Err.Number, Err.Source & ":Encrypt", Err.Description
strSecret = ""
Set oEN = Nothing
End Function