home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Virtual_En19489111162005.psc / clsCryptAPI.cls < prev    next >
Text File  |  2005-10-08  |  6KB  |  156 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsCryptAPI"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. 'CryptAPI Encryption/Decryption Class
  15. '------------------------------------
  16. '
  17. 'Information concerning the CryptAPI
  18. 'encryption/decryption can probably
  19. 'be found somewhere on M$ homepage
  20. 'http://www.microsoft.com/
  21. '
  22. '(c) 2000, Fredrik Qvarfort
  23. '
  24.  
  25. Option Explicit
  26.  
  27. Private m_Key As String
  28.  
  29. 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
  30. 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
  31. 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
  32. 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
  33. Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
  34. 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
  35. Private Declare Function CryptDestroyKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
  36. Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
  37. 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
  38.  
  39. Private Const SERVICE_PROVIDER As String = "Microsoft Base Cryptographic Provider v1.0"
  40. Private Const KEY_CONTAINER As String = "VIRTUAL ENCRYPTED DISK UTILITY v1.0"
  41. Private Const PROV_RSA_FULL As Long = 1
  42. Private Const CRYPT_NEWKEYSET As Long = 8
  43. Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
  44. Private Const ALG_CLASS_HASH As Long = 32768
  45. Private Const ALG_TYPE_ANY As Long = 0
  46. Private Const ALG_TYPE_STREAM As Long = 2048
  47. Private Const ALG_SID_RC4 As Long = 1
  48. Private Const ALG_SID_MD5 As Long = 3
  49. Private Const CALG_MD5 As Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
  50. Private Const CALG_RC4 As Long = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)
  51. Private Const ENCRYPT_ALGORITHM As Long = CALG_RC4
  52. Public Sub EncryptByte(ByteArray() As Byte, Optional Password As String)
  53.  
  54.   'Convert the array into a string, encrypt it
  55.   'and then convert it back to an array
  56.   
  57.   ByteArray() = StrConv(EncryptString(StrConv(ByteArray(), vbUnicode), Password), vbFromUnicode)
  58.  
  59. End Sub
  60.  
  61. Public Function EncryptString(Text As String, Optional Password As String) As String
  62.   
  63.   'Set the new key if any was sent to the function
  64.   If (Len(Password) > 0) Then Key = Password
  65.   
  66.   'Return the encrypted data
  67.   EncryptString = EncryptDecrypt(Text, True)
  68.  
  69. End Function
  70.  
  71. Public Sub DecryptByte(ByteArray() As Byte, Optional Password As String)
  72.  
  73.   'Convert the array into a string, decrypt it
  74.   'and then convert it back to an array
  75.   ByteArray() = StrConv(DecryptString(StrConv(ByteArray(), vbUnicode), Password), vbFromUnicode)
  76.  
  77. End Sub
  78.  
  79.  
  80. Public Function DecryptString(Text As String, Optional Password As String) As String
  81.   
  82.   'Set the new key if any was sent to the function
  83.   If (Len(Password) > 0) Then Key = Password
  84.   
  85.   'Return the decrypted data
  86.   DecryptString = EncryptDecrypt(Text, False)
  87.  
  88. End Function
  89.  
  90. Private Function EncryptDecrypt(ByVal Text As String, Encrypt As Boolean) As String
  91.   
  92.   Dim hKey As Long
  93.   Dim hHash As Long
  94.   Dim lLength As Long
  95.   Dim hCryptProv As Long
  96.   
  97.   'Get handle to CSP
  98.   If (CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, CRYPT_NEWKEYSET) = 0) Then
  99.     If (CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, 0) = 0) Then
  100.       Call Err.Raise(vbObjectError, , "Error during CryptAcquireContext for a new key container." & vbCrLf & "A container with this name probably already exists.")
  101.     End If
  102.   End If
  103.   
  104.   'Create a hash object to calculate a session
  105.   'key from the password (instead of encrypting
  106.   'with the actual key)
  107.   If (CryptCreateHash(hCryptProv, CALG_MD5, 0, 0, hHash) = 0) Then
  108.     Call Err.Raise(vbObjectError, , "Could not create a Hash Object (CryptCreateHash API)")
  109.   End If
  110.   
  111.   'Hash the password
  112.   If (CryptHashData(hHash, m_Key, Len(m_Key), 0) = 0) Then
  113.     Call Err.Raise(vbObjectError, , "Could not calculate a Hash Value (CryptHashData API)")
  114.   End If
  115.   
  116.   'Derive a session key from the hash object
  117.   If (CryptDeriveKey(hCryptProv, ENCRYPT_ALGORITHM, hHash, 0, hKey) = 0) Then
  118.     Call Err.Raise(vbObjectError, , "Could not create a session key (CryptDeriveKey API)")
  119.   End If
  120.   
  121.   'Encrypt or decrypt depending on the Encrypt parameter
  122.   lLength = Len(Text)
  123.   If (Encrypt) Then
  124.     If (CryptEncrypt(hKey, 0, 1, 0, Text, lLength, lLength) = 0) Then
  125.       Call Err.Raise(vbObjectError, , "Error during CryptEncrypt.")
  126.     End If
  127.   Else
  128.     If (CryptDecrypt(hKey, 0, 1, 0, Text, lLength) = 0) Then
  129.       Call Err.Raise(vbObjectError, , "Error during CryptDecrypt.")
  130.     End If
  131.   End If
  132.   
  133.   'Return the encrypted/decrypted data
  134.   EncryptDecrypt = Left$(Text, lLength)
  135.   
  136.   'Destroy the session key
  137.   If (hKey <> 0) Then Call CryptDestroyKey(hKey)
  138.   
  139.   'Destroy the hash object
  140.   If (hHash <> 0) Then Call CryptDestroyHash(hHash)
  141.   
  142.   'Release provider handle
  143.   If (hCryptProv <> 0) Then Call CryptReleaseContext(hCryptProv, 0)
  144.  
  145. End Function
  146. Public Property Let Key(New_Value As String)
  147.  
  148.   'Do nothing if no change was made
  149.   If (m_Key = New_Value) Then Exit Property
  150.   
  151.   'Set the new key
  152.   m_Key = New_Value
  153.   
  154. End Property
  155.  
  156.