[AccessD] RC1 encryption - was Re: Field Level AES Encryption

jwcolby jwcolby at colbyconsulting.com
Fri Apr 29 10:00:07 CDT 2011


Thanks to Gustav.  this is encryption, not hashing.

Option Compare Database
Option Explicit

' PC1 Cipher 128-bit key
' (c) Alexander Pukall 1991
' Can be used freely even for commercial applications
'
' MS Access 97 version by
' Gustav Brock, Cactus Data ApS
' gustav at cactus.dk
'
' 2002-03-09. V1.0
'   Initial port from Visual Basic.
' 2002-06-23. V1.1
'   Code clean up and constants added.
'   Redundant code removed.
'   Modified to fully comply with VB datatypes.
'   Modified to not crash for certain passwords.
'   Modified for high speed conversion of long strings ( > 32K).
' 2002-06-24. V1.2
'   Functions added for en/decrypting to/from binary strings.

' Usage:
'   SetPassword(password) sets password prior to en/decryption.
'   GetPassword() retrieves current password.
'   StrEncrypt(DecryptedString) returns encrypted ascii string.
'   StrDecrypt(EncryptedString_ascii) returns decrypted string.
'   StrEncryptBin(DecryptedString) returns encrypted binary string.
'   StrDecryptBin(EncryptedString_binary) returns decrypted string.
'
' Encrypted ascii string is twice the length of the decrypted string.
' Encrypted ascii string contains low ascii chars from a to p only.
' Encrypted binary string is same length as the decrypted string.
' Encrypted binary string may contain any char including Chr(0).
' Password may contain any ascii char including Chr(0).
' Password is maintained in global variable strPC1Password16.

   Private Const clngHexMax  As Long = &H10
   Private Const clngBytMax  As Long = &H100
   ' Maximum value of unsigned Integer.
   Private Const clngIntMax  As Long = &H10000
   ' clngAscMin defines beginning of a 16 letter range from a to p.
   Private Const clngAscMin  As Long = &H61

   Private strPC1Password16      As String * clngHexMax

   Private x1a0(9)           As Long
   Private cle(17)           As Long
   Private x1a2              As Long

   Private lngInt            As Long
   Private lngRes            As Long
   Private lngTmp            As Long

   Private ax                As Long
   Private bx                As Long
   Private cx                As Long
   Private dx                As Long
   Private si                As Long
   Private i                 As Long
   Private c                 As Long
   Private d                 As Long
   Private e                 As Long

   Private strEncrypted      As String
   Private strDecrypted      As String

Public Function SetPassword(ByRef strPassword As String) As Integer

   Dim intPasswordLength As Integer

   ' Remove leading and trailing spaces from password.
   strPassword = Trim(strPassword)

   ' Set global variable and limit password to fixed length of 16 characters.
   strPC1Password16 = strPassword

   ' Find and return net length of password.
   intPasswordLength = Len(strPassword)

   SetPassword = intPasswordLength

End Function

Public Function GetPassword() As String

   ' Get global variable strPC1Password16.
   GetPassword = RTrim(strPC1Password16)

End Function

Public Function StrEncrypt(ByVal strInput As String) As String

   strDecrypted = strInput
   Call Encrypt(False)

   StrEncrypt = strEncrypted

End Function

Public Function StrDecrypt(ByVal strInput As String) As String

   strEncrypted = strInput
   Call Decrypt(False)

   StrDecrypt = strDecrypted

End Function

Public Function StrEncryptBin(ByVal strInput As String) As String

   strDecrypted = strInput
   Call Encrypt(True)

   StrEncryptBin = strEncrypted

End Function

Public Function StrDecryptBin(ByVal strInput As String) As String

   strEncrypted = strInput
   Call Decrypt(True)

   StrDecryptBin = strDecrypted

End Function

Private Sub Encrypt(ByVal booBinary As Boolean)

   Dim strX  As String
   Dim lngC  As Long
   Dim lngD  As Long
   Dim lngM  As Long
   Dim lngN  As Long
   Dim lngX  As Long

   si = 0
   x1a2 = 0
   i = 0

   strX = strDecrypted
   lngX = Len(strX)
   strEncrypted = Space(lngX * (2 - Abs(booBinary)))

   For lngN = 1 To clngHexMax
     cle(lngN) = Asc(mID(strPC1Password16, lngN, 1))
   Next lngN

   For lngN = 1 To lngX
     c = Asc(mID(strX, lngN, 1))

     ' Calculate lngInt.
     Call Assemble

     lngC = lngInt \ clngBytMax
     lngD = lngInt Mod clngBytMax

     For lngM = 1 To clngHexMax
       cle(lngM) = cle(lngM) Xor c
     Next lngM

     c = c Xor (lngC Xor lngD)

     If booBinary = False Then
       ' Build ascii string.
       d = (c \ clngHexMax) Mod clngHexMax
       e = c Mod clngHexMax
       ' clngAscMin + d gives one letter range from a to p for the 4 high bits of c.
       ' clngAscMin + e gives one letter range from a to p for the 4 low bits of c.
       ' Perform high speed insertion of encrypted character.
       Mid(strEncrypted, (lngN * 2) - 1, 1) = Chr(clngAscMin + d)
       Mid(strEncrypted, (lngN * 2) - 0, 1) = Chr(clngAscMin + e)
     Else
       ' Build binary string.
       ' Perform high speed insertion of encrypted character.
       Mid(strEncrypted, lngN, 1) = Chr(c)
     End If
   Next lngN

End Sub

Private Sub Decrypt(ByVal booBinary As Boolean)

   Dim strX  As String
   Dim lngC  As Long
   Dim lngD  As Long
   Dim lngM  As Long
   Dim lngN  As Long
   Dim lngX  As Long

   si = 0
   x1a2 = 0
   i = 0

   strX = strEncrypted
   lngX = Len(strX) \ (2 - Abs(booBinary))
   strDecrypted = Space(lngX)

   For lngN = 1 To clngHexMax
     cle(lngN) = Asc(mID(strPC1Password16, lngN, 1))
   Next lngN

   For lngN = 1 To lngX
     If booBinary = False Then
       d = Asc(mID(strX, (lngN * 2) - 1, 1))
       If d >= clngAscMin Then
         ' Transform the letter to the 4 high bits of c.
         d = d - clngAscMin
         If d < clngHexMax Then
           d = d * clngHexMax
         End If
       End If
       e = Asc(mID(strX, (lngN * 2) - 0, 1))
       If e >= clngAscMin Then
         ' Transform the letter to the 4 low bits of c.
         e = e - clngAscMin
         If e < clngHexMax Then
           c = d + e
         End If
       End If
     Else
       c = Asc(mID(strX, lngN, 1))
     End If

     ' Calculate lngInt.
     Call Assemble

     lngC = (lngInt \ clngBytMax) Mod clngBytMax
     lngD = lngInt Mod clngBytMax
     c = c Xor (lngC Xor lngD)

     For lngM = 1 To clngHexMax
       cle(lngM) = cle(lngM) Xor c
     Next lngM

     ' Perform high speed insertion of decrypted character.
     Mid(strDecrypted, lngN, 1) = Chr(c)
   Next lngN

End Sub

Private Sub Assemble()

   Dim lngM  As Long
   Dim lngN  As Long

   x1a0(0) = ((cle(1) * clngBytMax) + cle(2)) Mod clngIntMax
   Call Code
   lngInt = lngRes

   For lngM = 1 To (clngHexMax / 2) - 1
     lngN = lngM * 2
     x1a0(lngM) = x1a0(lngM - 1) Xor ((cle(lngN + 1) * clngBytMax) + cle(lngN + 2))
     Call Code
     lngInt = lngInt Xor lngRes
   Next lngM

   i = 0

End Sub

Private Sub Code()

   Const clngKeyB  As Long = &H4E35
   Const clngKeyC  As Long = &H15A

   dx = (x1a2 + i) Mod clngIntMax
   ax = x1a0(i)
   cx = clngKeyC
   bx = clngKeyB

   lngTmp = ax
   ax = si
   si = lngTmp

   lngTmp = ax
   ax = dx
   dx = lngTmp

   If (ax <> 0) Then
     ax = ((ax Mod clngIntMax) * (bx Mod clngIntMax)) Mod clngIntMax
   End If

   lngTmp = ax
   ax = cx
   cx = lngTmp

   If (ax <> 0) Then
     ax = ((ax Mod clngIntMax) * (si Mod clngIntMax)) Mod clngIntMax
     cx = (ax + cx) Mod clngIntMax
   End If

   lngTmp = ax
   ax = si
   si = lngTmp
   ax = ((ax Mod clngIntMax) * (bx Mod clngIntMax)) Mod clngIntMax
   dx = (cx + dx) Mod clngIntMax

   ax = ax + 1

   x1a2 = dx
   x1a0(i) = ax

   lngRes = ax Xor dx
   i = i + 1

End Sub



John W. Colby
www.ColbyConsulting.com

On 4/28/2011 5:21 PM, Asger Blond wrote:
> How do you create the hash - any generator to recommend?
> Asger



More information about the AccessD mailing list