VB and VBA Users Source Code: Encryption class for password encrypting text (uses XOR)
[
Home
|
Contents
|
Search
|
Reply
| Previous |
Next
]
VB/VBA Source Code
Encryption class for password encrypting text (uses XOR)
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Thursday, July 28, 2005
Hits:
5027
Category:
Visual Basic General
Article:
Below is an encryption class that encrypts both ASCII and Unicode text using a password. An example of how to use the class is given below: 'Demo routine Sub Test() Dim oEncrypt As clsEncrypt Dim sText As String Dim bIsUnicde As Boolean Set oEncrypt = New clsEncrypt bIsUnicde = False 'Set password oEncrypt.Password = "andrewbakerisace" sText = "my secret text" 'Encrypt text Debug.Print "Before encryption: " & sText sText = oEncrypt.EncryptOrDecrypt(sText, bIsUnicde) Debug.Print "After encryption: " & sText 'Decrypt text sText = oEncrypt.EncryptOrDecrypt(sText, bIsUnicde) Debug.Print "After unencrypting: " & sText End Sub ADD TO A CLASS MODULE CALLED "clsEncrypt" ----------------------------------------- ----------------------------------------- 'Copyright 2005 www.vbusers.com 'Encryption class for encrypting and decrypting text using a password and an XOR operator. 'Written by Andrew Baker 'For the Terms and conditions see http://www.vbusers.com/TermsAndConditions.asp Option Explicit '---------------Private class variables----------------- Private zsPassword As String 'Purpose : Gets or sets the password used by the encryption routines 'Inputs : N/A 'Outputs : N/A 'Date : 25/03/2005 'Notes : Property Get Password() As String Password = zsPassword End Property Property Let Password(value As String) zsPassword = value End Property 'Purpose : Encrypts or decrypts the supplied string. 'Inputs : sData The data to process. ' [bUseUnicode] If true, converts unicode text else converts ASCII text. 'Outputs : Returns an encrypted string if the input was unencrypted, or a decrypted string if ' the input was encrypted/ 'Date : 25/03/2005 'Notes : Function EncryptOrDecrypt(sData As String, Optional bUseUnicode As Boolean = False) As String Dim abData() As Byte, abPassword() As Byte If Len(sData) > 0 And Len(zsPassword) > 0 Then If bUseUnicode Then abData = sData abPassword = zsPassword Else 'All VB text is stored in Unicode, so must convert back to ASCII first abData = StrConv(sData, vbFromUnicode) abPassword = StrConv(zsPassword, vbFromUnicode) End If EncryptOrDecrypt = zEncryptArray(abData, abPassword, bUseUnicode) Else 'Either no data or password has been set EncryptOrDecrypt = sData End If End Function 'Purpose : Encrypts or decrypts the specified byte array using the password string with an XOR operator. 'Inputs : abData A byte array containing the data to encrypt. ' abPassword The password to encrypt the data with. 'Outputs : Returns the encrypted or decrypted byte array. 'Date : 25/03/2001 'Notes : Private Function zEncryptArray(abData() As Byte, abPassword() As Byte, bUseUnicode As Boolean) As Byte() Dim lThisLine As Long Dim abResults() As Byte Dim lPasswordIndex As Long On Error GoTo ErrFailed 'Size the array to store the resulting data ReDim abResults(LBound(abData) To UBound(abData)) 'Loop over each byte in the data array, apply the encryption algorithm For lThisLine = 0 To UBound(abData) 'Encrypt the byte abResults(lThisLine) = zEncryptByte(abData(lThisLine), abPassword, lPasswordIndex) Next 'Return the results If bUseUnicode Then 'Array will already be in Unicode format zEncryptArray = abResults Else 'Have to convert back to Unicode before storing as a string zEncryptArray = StrConv(abResults, vbUnicode) End If Exit Function ErrFailed: Debug.Print "Error in zEncryptArray: " & Err.Description Debug.Assert False End Function 'Purpose : This function Encrypts one byte, then modifies the password. 'Inputs : bytValue A byte array containing the data to encrypt. ' abPassword The password to encrypt the data with. 'Outputs : Returns the input byte after the encryption algorithm has been applied to it. 'Author : Andrew Baker 'Date : 04/09/2000 'Notes : Modifies the password bytes after each iteration to make decryption harder. 'Revisions : Private Function zEncryptByte(bytValue As Byte, abPassword() As Byte, lPasswordIndex As Long) As Byte On Error GoTo ErrFailed If lPasswordIndex = UBound(abPassword) - 1 Then 'Text exceeded password, reset password array lPasswordIndex = 0 End If 'Exclusive or the byte with the current password byte zEncryptByte = bytValue Xor abPassword(lPasswordIndex) 'Exclusive or the byte with the first character of the password 'multiplied by the current index into the password. And the result with '256 to avoid possible overflow errors zEncryptByte = (zEncryptByte Xor CInt(abPassword(lPasswordIndex)) * lPasswordIndex) And &HFF 'Modify the password. 'set the current byte in the password to the current byte plus the next byte. abPassword(lPasswordIndex) = (CInt(abPassword(lPasswordIndex)) + abPassword(lPasswordIndex + 1)) And &HFF 'Increment the password index lPasswordIndex = lPasswordIndex + 1 Exit Function ErrFailed: Debug.Print "Error in zEncryptByte: " & Err.Description Debug.Assert False End Function
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
