Gustav Brock
Gustav at cactus.dk
Mon Feb 28 10:47:03 CST 2005
Hi JR
What you describe is en/decryption, not a hash algorithm which is "one
way" only.
We use the module below for this which runs very fast.
/gustav
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
Public 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
---
>>> JRojas at tnco-inc.com 28-02-2005 17:22:40 >>>
Hello,
I am looking a code snippet that would take in a string and convert it
to a
fixed length encrypted string. As well as a code snippet that would
take the
encrypted string and return the original string.
Preferably in VB or vbscript.
I am trying to create a session-less web application but there are
times
where information needs to be passed from page to page, like someone's
username, that is sensitive and wouldn't want someone either reading
or
sending it themselves. If I can encrypt this string, it would stop
casual
users from sending this data themselves by creating a web page with a
form
and posting it to the web server.
Thanks,
JR
This electronic transmission is strictly confidential to TNCO, Inc.
and
intended solely for the addressee. It may contain information which is
covered by legal, professional, or other privileges. If you are not
the
intended addressee, or someone authorized by the intended addressee to
receive transmissions on behalf of the addressee, you must not retain,
disclose in any form, copy, or take any action in reliance on this
transmission. If you have received this transmission in error, please
notify
the sender as soon as possible and destroy this message. While TNCO,
Inc.
uses virus protection, the recipient should check this email and any
attachments for the presence of viruses. TNCO, Inc. accepts no
liability for
any damage caused by any virus transmitted by this email.
_______________________________________________
dba-Tech mailing list
dba-Tech at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/dba-tech
Website: http://www.databaseadvisors.com