Looking for a BAS Module for Crypto API

[Lothar Haensler]

does anyone have a BAS module that uses the CryptoAPI functions.
I want to encrypt/decrypt a string using the CryptoAPI.
No self-written encryption algorithms, please.

I have searched this forum and the codeguru site (only c++ code found), no luck.

There was a VBPJ article in VBPJ0298, but I don't have access to that.

Thanks in advance.

[Chris Eastwood]

Here you go - original author comments in the header.


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Description: This module provides encryption/decryption through
' the CryptoAPI. This is the standard API you can use
' regardless of the underlying dll used to do the encryption.
' These dlls are called Cryptographic Service Providers (CSPs)
' and you get one as standard from Microsoft called
' "Microsoft Base Cryptographic Provider v1.0"
' This module uses the standard CSP, but this can be changed
' by changing the constant SERVICE_PROVIDER
' There is additional code in this module to ensure that
' the encrypted values do not contain CR or LF characters
' so that the result can be written to a file
'
' A word of warning:
' If you are going to use WritePrivateProfileString to write the
' encrypted value to an ini file, you must write a null first
' to delete the existing entry as it does not clear previous
' entries when writing binary data. This is a problem if you
' are overwriting a value with a smaller one.
'
' Example usage:
'
' private Const MY_PASSWORD as string = "isdflkaatdfuhwfnasdf"
'
' public Sub Main()
' Dim sEncrypted as string
' EncryptionCSPConnect
' sEncrypted = EncryptData("hello world", MY_PASSWORD)
' MsgBox DecryptData(sEncrypted, MY_PASSWORD)
' EncryptionCSPDisconnect
' End Sub
'
'
' Created By: Barry Dunne
' date Created: 31 Jan 2000
'
' public Interface:
'
' Function EncryptionCSPConnect() as Boolean
' - Connect to CSP, must be called before using encryption
' Function EncryptData(byval Data as string, byval Password as string) as string
' - Encrypt a string
' Function DecryptData(byval Data as string, byval Password as string) as string
' - Decrypt a string
' Function GetCSPDetails() as string
' - Returns the CSP details
' Sub EncryptionCSPDisconnect()
' - Release handle, must be called when finished using encryption
'
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

option Explicit

private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" _
(byref phProv as Long, _
byval pszContainer as string, _
byval pszProvider as string, _
byval dwProvType as Long, _
byval dwFlags as Long) as Long

private Declare Function CryptGetProvParam Lib "advapi32.dll" _
(byval hProv as Long, _
byval dwParam as Long, _
byref pbData as Any, _
byref pdwDataLen as Long, _
byval dwFlags as Long) as Long

private Declare Function CryptCreateHash Lib "advapi32.dll" _
(byval hProv as Long, _
byval Algid as Long, _
byval hKey as Long, _
byval dwFlags as Long, _
byref phHash as Long) as Long

private Declare Function CryptHashData Lib "advapi32.dll" _
(byval hHash as Long, _
byval pbData as string, _
byval dwDataLen as Long, _
byval dwFlags as Long) as Long

private Declare Function CryptDeriveKey Lib "advapi32.dll" _
(byval hProv as Long, _
byval Algid as Long, _
byval hBaseData as Long, _
byval dwFlags as Long, _
byref phKey as Long) as Long

private Declare Function CryptDestroyHash Lib "advapi32.dll" _
(byval hHash as Long) as Long

private Declare Function CryptEncrypt Lib "advapi32.dll" _
(byval hKey as Long, _
byval hHash as Long, _
byval Final as Long, _
byval dwFlags as Long, _
byval pbData as string, _
byref pdwDataLen as Long, _
byval dwBufLen as Long) as Long

private Declare Function CryptDestroyKey Lib "advapi32.dll" _
(byval hKey as Long) as Long

private Declare Function CryptReleaseContext Lib "advapi32.dll" _
(byval hProv as Long, _
byval dwFlags as Long) as Long

private Declare Function CryptDecrypt Lib "advapi32.dll" _
(byval hKey as Long, _
byval hHash as Long, _
byval Final as Long, _
byval dwFlags as Long, _
byval pbData as string, _
byref pdwDataLen as Long) as Long

private Const SERVICE_PROVIDER as string = "Microsoft Base Cryptographic Provider v1.0"
private Const KEY_CONTAINER as string = "Metallica"
private Const PROV_RSA_FULL as Long = 1
private Const PP_NAME as Long = 4
private Const PP_CONTAINER as Long = 6
private Const CRYPT_NEWKEYSET as Long = 8
private Const ALG_CLASS_DATA_ENCRYPT as Long = 24576
private Const ALG_CLASS_HASH as Long = 32768
private Const ALG_TYPE_ANY as Long = 0
private Const ALG_TYPE_STREAM as Long = 2048
private Const ALG_SID_RC4 as Long = 1
private Const ALG_SID_MD5 as Long = 3
private Const CALG_MD5 as Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
private Const CALG_RC4 as Long = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)
private Const ENCRYPT_ALGORITHM as Long = CALG_RC4
private Const NUMBER_ENCRYPT_PASSWORD as string = "´o¸sçPQ]"

private hCryptProv as Long
'
public Function EncryptionCSPConnect() as Boolean
'get handle to CSP
If CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, CRYPT_NEWKEYSET) = 0 then
If CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, 0) = 0 then
HandleError "error during CryptAcquireContext for a new key container." & vbCrLf & _
"A container with this name probably already exists."
EncryptionCSPConnect = false
Exit Function
End If
End If

EncryptionCSPConnect = true
End Function
'
public Sub EncryptionCSPDisconnect()
'Release provider handle.
If hCryptProv <> 0 then
CryptReleaseContext hCryptProv, 0
End If
End Sub
'
public Function EncryptData(byval Data as string, byval Password as string) as string
Dim sEncrypted as string
Dim lEncryptionCount as Long
Dim sTempPassword as string

'It is possible that the normal encryption will give you a string
'containing cr or lf characters which make it difficult to write to files
'Do a loop changing the password and keep encrypting until the result is ok
'to be able to decrypt we need to also store the number of loops in the result

'Try first encryption
lEncryptionCount = 0
sTempPassword = Password & lEncryptionCount
sEncrypted = EncryptDecrypt(Data, sTempPassword, true)

'Loop if this contained a bad character
' Do While (InStr(1, sEncrypted, vbCr) > 0) _
' Or (InStr(1, sEncrypted, vbLf) > 0) _
' Or (InStr(1, sEncrypted, Chr$(0)) > 0) _
' Or (InStr(1, sEncrypted, vbTab) > 0)
'
' 'Try the next password
' lEncryptionCount = lEncryptionCount + 1
' sTempPassword = Password & lEncryptionCount
' sEncrypted = EncryptDecrypt(Data, sTempPassword, true)
'
' 'Don't go on for ever, 1 billion attempts should be plenty
' If lEncryptionCount = 99999999 then
' Err.Raise vbObjectError + 999, "EncryptData", "This data cannot be successfully encrypted"
' EncryptData = ""
' Exit Function
' End If
' Loop

'Build encrypted string, starting with number of encryption iterations
EncryptData = EncryptNumber(lEncryptionCount) & sEncrypted
End Function
'
public Function DecryptData(byval Data as string, byval Password as string) as string
Dim lEncryptionCount as Long
Dim sDecrypted as string
Dim sTempPassword as string

'When encrypting we may have gone through a number of iterations
'How many did we go through?
lEncryptionCount = DecryptNumber(mid$(Data, 1, 8))

'start with the last password and work back
sTempPassword = Password & lEncryptionCount
sDecrypted = EncryptDecrypt(mid$(Data, 9), sTempPassword, false)

DecryptData = sDecrypted
End Function
'
public Function GetCSPDetails() as string
Dim lLength as Long
Dim yContainer() as Byte

If hCryptProv = 0 then
GetCSPDetails = "Not connected to CSP"
Exit Function
End If
'
'for developer info, show what the CSP & container name is
lLength = 1000
ReDim yContainer(lLength)
If CryptGetProvParam(hCryptProv, PP_NAME, yContainer(0), lLength, 0) <> 0 then
GetCSPDetails = "Cryptographic Service Provider name: " & ByteToStr(yContainer, lLength)
End If
lLength = 1000
ReDim yContainer(lLength)
If CryptGetProvParam(hCryptProv, PP_CONTAINER, yContainer(0), lLength, 0) <> 0 then
GetCSPDetails = GetCSPDetails & vbCrLf & "Key Container name: " & ByteToStr(yContainer, lLength)
End If
End Function
'
private Function EncryptDecrypt(byval Data as string, byval Password as string, byval Encrypt as Boolean) as string
Dim lLength as Long
Dim sTemp as string
Dim hHash as Long
Dim hKey as Long
'
If hCryptProv = 0 then
HandleError "Not connected to CSP"
Exit Function
End If
'
'--------------------------------------------------------------------
'The data will be encrypted with a session key derived from the
'password.
'The session key will be recreated when the data is decrypted
'only if the password used to create the key is available.
'--------------------------------------------------------------------
'
'Create a hash object.
If CryptCreateHash(hCryptProv, CALG_MD5, 0, 0, hHash) = 0 then
HandleError "error during CryptCreateHash!"
End If
'
'Hash the password.
If CryptHashData(hHash, Password, len(Password), 0) = 0 then
HandleError "error during CryptHashData."
End If
'
'Derive a session key from the hash object.
If CryptDeriveKey(hCryptProv, ENCRYPT_ALGORITHM, hHash, 0, hKey) = 0 then
HandleError "error during CryptDeriveKey!"
End If
'
' 'Do the work
sTemp = Data
lLength = len(Data)
If Encrypt then
'Encrypt data.
If CryptEncrypt(hKey, 0, 1, 0, sTemp, lLength, lLength) = 0 then
HandleError "error during CryptEncrypt."
End If
else
'Encrypt data.
If CryptDecrypt(hKey, 0, 1, 0, sTemp, lLength) = 0 then
HandleError "error during CryptDecrypt."
End If
End If
'
'This is what we return.
EncryptDecrypt = mid$(sTemp, 1, lLength)
'
'Destroy session key.
If hKey <> 0 then
CryptDestroyKey hKey
End If
'
'Destroy hash object.
If hHash <> 0 then
CryptDestroyHash hHash
End If
End Function
'
private Sub HandleError(byval error as string)
'You could write the error to the screen or to a file
Debug.print error
End Sub
'
private Function ByteToStr(byref ByteArray() as Byte, byval lLength as Long) as string
Dim i as Long
for i = LBound(ByteArray) to (LBound(ByteArray) + lLength)
ByteToStr = ByteToStr & Chr$(ByteArray(i))
next i
End Function
'
private Function EncryptNumber(byval lNumber as Long) as string
Dim i as Long
Dim sNumber as string
'
sNumber = Format$(lNumber, "00000000")
'
for i = 1 to 8
EncryptNumber = EncryptNumber & Chr$(Asc(mid$(NUMBER_ENCRYPT_PASSWORD, i, 1)) + Val(mid$(sNumber, i, 1)))
next i
End Function
'
private Function DecryptNumber(byval sNumber as string) as Long
Dim i as Long
'
for i = 1 to 8
DecryptNumber = (10 * DecryptNumber) + (Asc(mid$(sNumber, i, 1)) - Asc(mid$(NUMBER_ENCRYPT_PASSWORD, i, 1)))
next i
End Function








Chris Eastwood

CodeGuru - the website for developers
http://codeguru.developer.com/vb

[Lothar Haensler]

Thank you very much.

I have been searching the web for hours.
it works great and is easy to use, too.
Exactly what I was looking for.

[Chris Eastwood]

>I have been searching the web for hours.

I thought you might have checked with us first ;-)

<disclaimer>
I'm not too sure about the legal implications of using the code outside of the US - the code is shown on that page purely as a learning process and may be illegal to use in your application.
</disclaimer>



Chris Eastwood

CodeGuru - the website for developers
http://codeguru.developer.com/vb

[Lothar Haensler]

>I thought you might have checked with us first
Of course, I did. As I said, I have searched the forum and the codeguru site...

I don't see any legal problems. The cryptoapi is part of the operating system.

[Johnny101]

I'm not terribly familiar with the ins and outs of encryption techniques yet, so forgive me if i'm misunderstanding something here.
What is the purpose of the MY_PASSWORD string that is passed to and from the encryption routines? Is it sort of like the key to encryption? (like SSL uses the Public Key Encryption) In which case, it wouldn't matter what that value was, as long as it was the same for both the encrypt and decrypt routines - right? Or am i totally off here?

Thanks,

John

John Pirkey
MCSD
www.ShallowWaterSystems.com

[Johnny101]

Lothar, I have access to that article, if you still want it, you can download it and the source from here: http://briefcase.yahoo.com/mailjohnny101 Then click on VB Stuff folder (the only one you should able to see) and then download the zip file.

Have fun,
john

John Pirkey
MCSD
www.ShallowWaterSystems.com

[Lothar Haensler]

>In which case, it wouldn't matter what that value was, as long as it was the same for both the encrypt and decrypt routines - right?

I think you are right.

[Ravi Kiran]

Hi,

A quick test: just copy the code including the same "Hello World" sample, shows that the Msgbox "hello world" comes up with 2 chars less!!.

It has only "hello wor". Did anybody else try this sample?

I haven't gone thru the code yet. but just first impression....

RK

[Lothar Haensler]

Thanks a lot.
I already used the code posted by Chris, though.

[Chris Eastwood]

I've noticed some problems with it too (it's not my code though ) - usually when the text that you are encrypting is over a certain length, or the length of the password. One of these two parameters is causing some problems with it (although I don't have time to checkout why at the moment)

Any takers ? (Ravi ?


Chris Eastwood

CodeGuru - the website for developers
http://codeguru.developer.com/vb

[Lothar Haensler]

I have tested it and used it and haven#t experienced any problems.
just encrypt and decrypt again.
The result will be identical to the original string.
At least in my tests.

[Chris Eastwood]

Try putting some really large text strings into the encryption routine (eg. I usually test these things with the contents of a large BAS module) - I found that sometimes the encryption would be fine, but depending on the length of the password, not all of the text would be decrypted.

I'll see if I can come up with a specific example.


Chris Eastwood

CodeGuru - the website for developers
http://codeguru.developer.com/vb

[Lothar Haensler]

Ok, you may be right.
I only used it for text strings with a maximum length of 255 chars.

[Ravi Kiran]

I was thinking more in terms of "Non-internationalised" code :-) ( quick looks again!)

Because mine is Japanese. VB ( and NT unicode ? )and functions like MID$ behave very differently in those environment. They work on whole chars ( which can be 1 byte or 2 bytes)

My own contention is: that problem is with the code which around the encrpyption logic
I even tried to to replace the MID$ with my known versions, but still couldn't get it to work.

Take a look at this: ( I hope "he" wont mind us discussing "his" code here! )

' 'Do the work
sTemp = Data
lLength = len(Data)
If Encrypt then
'Encrypt data.
If CryptEncrypt(hKey, 0, 1, 0, sTemp, lLength, lLength) = 0 then
HandleError "error during CryptEncrypt."
End If
else
'Encrypt data.
If CryptDecrypt(hKey, 0, 1, 0, sTemp, lLength) = 0 then
HandleError "error during CryptDecrypt."
End If
End If
'
'This is what we return.
EncryptDecrypt = mid$(sTemp, 1, lLength)




Specially at the decrypting time, it is likely to be non-ascii, and the length given by Len will be wrong. I stepped thru the code, and noticed it too.

May be the whole logic can be replaced to work with byte arrays!


RK