Crypto API using RC2 instead of RC4?

From: Matt (mtaylor_at_gladstonemrm.com)
Date: 11/22/05 

Date: 22 Nov 2005 10:02:16 -0800

Hello,

The code below works fine for encrypting and decrypting but I need to
change it to use RC2 instead of RC4.
This is because the .NET application that is going to do the decrypting
uses RC2.

I thought it would be a simple matter of changing the ENCRYPT_ALGORITHM
constant to CALG_RC2, but doing this causes the decrypt to fail with
complaints about the number of bytes.

This code is very much a work in progress and is based on some that I
found here:
http://groups.google.co.uk/group/microsoft.public.vb.winapi/browse_thread/thread/ef6301b4cd280e0b/9358960af9b30916

I hope someone can help.

Thanks in advance.

Matt

** Start Code **

Public sPassword As String
Public sInputBuffer As String
Public sOutputBuffer As String

'constants for Cryptography API functions
Private Const CRYPT_NEWKEYSET = &H8
Private Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider
v1.0"
Private Const PROV_RSA_FULL = 1
Private Const ALG_CLASS_DATA_ENCRYPT = 24576
Private Const ALG_CLASS_HASH = 32768

Private Const ALG_TYPE_ANY = 0
Private Const ALG_TYPE_BLOCK = 1536
Private Const ALG_TYPE_STREAM = 2048
Private Const ALG_SID_RC2 = 2
Private Const ALG_SID_RC4 = 1
Private Const ALG_SID_MD5 = 3
Private Const ALG_SID_SHA1 = 4

Private Const CALG_MD5 = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or
ALG_SID_MD5)
Private Const CALG_RC2 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK) Or
ALG_SID_RC2)
Private Const CALG_RC4 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM)
Or ALG_SID_RC4)
Private Const CALG_SHA1 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or
ALG_SID_SHA1

Private Const ENCRYPT_ALGORITHM = CALG_RC4

Public Sub CryptoEncrypt()

Dim lHHash As Long
Dim lHkey As Long
Dim lResult As Long
Dim lHExchgKey As Long
Dim lHCryptprov As Long

Dim sContainer As String
Dim lCryptLength As Long
Dim lCryptBufLen As Long
Dim sCryptBuffer As String

   On Error GoTo EncryptError

   'Get handle to the default CSP
   sProvider = MS_DEF_PROV & vbNullChar
   If Not CBool(CryptAcquireContext(lHCryptprov, 0&, sProvider,
PROV_RSA_FULL, 0)) Then
       'If there is no default key container then create one using
Flags field
       If GetLastError = 0 Then
           If Not CBool(CryptAcquireContext(lHCryptprov, 0&, sProvider,
PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
               MsgBox ("Error " & CStr(GetLastError) & " during
CryptAcquireContext! ")
               GoTo Finished
           End If
       End If
   End If

   'Create a hash object
   If Not CBool(CryptCreateHash(lHCryptprov, CALG_SHA1, 0, 0, lHHash))
Then
       MsgBox ("Error " & CStr(GetLastError) & " during
CryptCreateHash!")
       GoTo Finished
   End If

   'Hash in the password text
   If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0))
Then
       MsgBox ("Error " & CStr(GetLastError) & " during
CryptHashData!")
       GoTo Finished
   End If

   'Create a session key from the hash object.
   If Not CBool(CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash,
0, lHkey)) Then
       MsgBox ("Error " & CStr(GetLastError) & " during
CryptDeriveKey!")
       GoTo Finished
   End If

   'Destroy the hash object.
   CryptDestroyHash (lHHash)
   lHHash = 0

   'Create a buffer for the CryptEncrypt function
   lCryptLength = Len(sInputBuffer)
   lCryptBufLen = lCryptLength * 2
   sCryptBuffer = String(lCryptBufLen, vbNullChar)
   LSet sCryptBuffer = sInputBuffer

   'Encrypt the text data
   If Not CBool(CryptEncrypt(lHkey, 0, 1, 0, sCryptBuffer,
lCryptLength, lCryptBufLen)) Then
       MsgBox ("bytes required:" & CStr(lCryptLength))
       MsgBox ("Error " & CStr(GetLastError) & " during CryptEncrypt!")
   End If

   sOutputBuffer = Mid$(sCryptBuffer, 1, lCryptLength)

Finished:

   'Destroy session key.
   If (lHkey) Then lResult = CryptDestroyKey(lHkey)

   'Destroy key exchange key handle
   If lHExchgKey Then CryptDestroyKey (lHExchgKey)

   'Destroy hash object
   If lHHash Then CryptDestroyHash (lHHash)

   'Release Context provider handle
   If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)

   Exit Sub

EncryptError:

   MsgBox ("Encrypt Error: " & Error$)

   GoTo Finished

End Sub

Public Sub CryptoDecrypt()
Dim lHExchgKey As Long
Dim lHCryptprov As Long
Dim lHHash As Long
Dim lHkey As Long
Dim lResult As Long

Dim sProvider As String

Dim sCryptBuffer As String
Dim lCryptBufLen As Long
Dim lCryptPoint As Long

Dim lPasswordPoint As Long
Dim lPasswordCount As Long

   On Error GoTo DecryptError

   'Clear the Output buffer
   sOutputBuffer = ""

   'Get handle to the default CSP.
   sProvider = vbNullChar
   sProvider = MS_DEF_PROV & vbNullChar
   If Not CBool(CryptAcquireContext(lHCryptprov, 0&, sProvider,
PROV_RSA_FULL, 0)) Then
       MsgBox ("Error " & CStr(GetLastError) & " during
CryptAcquireContext!")
       GoTo Finished
   End If

   'Create a hash object
   If Not CBool(CryptCreateHash(lHCryptprov, CALG_SHA1, 0, 0, lHHash))
Then
       MsgBox ("Error " & CStr(GetLastError) & " during
CryptCreateHash!")
       GoTo Finished
   End If

   'Hash in the password text
   If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0))
Then
       MsgBox ("Error " & CStr(GetLastError) & " during
CryptHashData!")
       GoTo Finished
   End If

   'Create a session key from the hash object
   If Not CBool(CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash,
0, lHkey)) Then
       MsgBox ("Error " & CStr(GetLastError) & " during
CryptDeriveKey!")
       GoTo Finished
   End If

   'Destroy the hash object.
   CryptDestroyHash (lHHash)
   lHHash = 0

   'Prepare sCryptBuffer for CryptDecrypt
   lCryptBufLen = Len(sInputBuffer) * 2
   sCryptBuffer = String(lCryptBufLen, vbNullChar)
   LSet sCryptBuffer = sInputBuffer

   'Decrypt data
   If Not CBool(CryptDecrypt(lHkey, 0, 1, 0, sCryptBuffer,
lCryptBufLen)) Then
       MsgBox ("bytes required:" & CStr(lCryptBufLen))
       MsgBox ("Error " & CStr(GetLastError) & " during CryptDecrypt!")
       GoTo Finished
   End If

   'Setup output buffer with just decrypted data
   sOutputBuffer = Mid$(sCryptBuffer, 1, lCryptBufLen / 2)

Finished:

   'Destroy session key
   If (lHkey) Then lResult = CryptDestroyKey(lHkey)

   'Destroy key exchange key handle
   If lHExchgKey Then CryptDestroyKey (lHExchgKey)

   'Destroy hash object
   If lHHash Then CryptDestroyHash (lHHash)

   'Release Context provider handle
   If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)

   Exit Sub

DecryptError:
   MsgBox ("Decrypt Error: " & Error$)
   GoTo Finished
   
End Sub

** End Code **

Relevant Pages

  • Re: Visual basic for a rightkey command
    ... Dim arrAs Long ... Sub Displaycursor() ... Private Const MOUSEEVENTF_LEFTDOWN = &H2 ... Dim lFlags As Long ...
    (microsoft.public.excel.programming)
  • Re: GetProcessByName
    ... Private Const PROCESS_ALL_ACCESS = &H1F0FFF ... Private Declare Function CloseHandle Lib "kernel32" (_ ... ByVal lpBasename As String, ... Dim pbolRtn As Boolean ...
    (microsoft.public.vb.winapi)
  • Re: A program is trying to access e-mail addresses...
    ... Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 ... Dim SH As Shell32.Shell ... Dim oAttachment As Outlook.Attachment ' Holds the email ... ' Make the user the folder selection dialog ...
    (microsoft.public.outlook.program_vba)
  • Re: Access 2007 Runtime Error When Clicking Access Close Button
    ... Private Const WS_CAPTION = &HC00000 ... ByVal nIndex As Long _ ... Dim nIndex As Long ... Dim dwNewLong As Long ...
    (comp.databases.ms-access)
  • Re: LoadPicture and SafeLoadImage
    ... remedied by a piece of code called SafeLoadimage which allows me to trap the error and stop the crash but does anyone ... ByVal hDC As Long, ByRef pBitmapInfo As Any, ByVal un As Long, ByRef lplpVoid As Long, _ ... Private Const JPEG_CMYK As Long = &H1000 ... Dim HeadPtr As Long, DataPtr As Long ...
    (microsoft.public.vb.winapi.graphics)