VB6 encrypts text using password

Question

We are looking for a simple VB6 code encryption / decryption code. Ideally, the solution should take arguments (text, password) and output readable output (without any special characters), so it can be used anywhere without encoding problems.

There is a lot of code for .NET, but actually I can not find for old VB6. Only this I have found so far: http://www.devx.com/vb2themax/Tip/19211

Answer 1

I am using an 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 may need more efficient error handling on FromHexDump .

Answer 2

MD5sum text and password together as a one-way hash (and then check, you will encrypt again and compare with the saved hash. (This will not work if you MUST decrypt it again)

Answer 3

Here is my encryption class. I use several constants to determine the encryption key, because, in my opinion, it is a little safer from someone trying to decompile the code to find it. Cryptography is not my business, so maybe I'm joking. Anyway, I used this class in the ActiveX DLL, called from other programs, for encryption and the opposite in a separate dll for decryption. I made it so that people who should not see encrypted data do not even have a dll to decrypt. Change the key constants to what you want (5 long). I use the mix, including non-printable characters, and it still worked well for me. CAPICOM is part of Windows & reg; therefore you do not need 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