home *** CD-ROM | disk | FTP | other *** search
/ Computer Shopper 121 / Computer Shopper 121 / Computer Shopper 121.iso / Editor.ial / Program / CRYPT.CLS next >
Encoding:
Visual Basic class definition  |  1997-12-15  |  5.1 KB  |  153 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "Crypt"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (hProv As Long, ByVal Container As String, ByVal Provider As String, ByVal ProvType As Long, ByVal dwFlags As Long) As Long
  11. Private Declare Function CryptSetProvider Lib "advapi32.dll" Alias "CryptSetProviderA" (ByVal Provider As String, ByVal ProvType As Long) As Long
  12. Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, hHash As Long) As Long
  13. Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, data As Byte, ByVal datalen As Long, ByVal dwFlags As Long) As Long
  14. Private Declare Function CryptDeriveKey Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hHash As Long, ByVal dwFlags As Long, hKey As Long) As Long
  15. Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
  16. Private Declare Function CryptDestroyKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
  17. Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
  18. Private Declare Function GetLastError Lib "kernel32.dll" () As Long
  19. Private Declare Function CryptEncrypt Lib "advapi32.dll" (ByVal hKey As Long, ByVal hHash As Long, ByVal Final As Boolean, ByVal dwFlags As Long, data As Byte, datalen As Long, ByVal BuffLen As Long) As Long
  20. Private Declare Function CryptDecrypt Lib "advapi32.dll" (ByVal hKey As Long, ByVal hHash As Long, ByVal Final As Boolean, ByVal dwFlags As Long, data As Byte, datalen As Long) As Long
  21.  
  22.  
  23. Private hProv As Long
  24. Private result As Long
  25. Private hKey As Long
  26. Private mPass As String
  27. Private data() As Byte
  28.  
  29. Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"
  30. Const PROV_RSA_FULL As Long = 1&
  31. Const CALG_MD5 As Long = &H8003&
  32. Const CALG_RC2 As Long = &H6602&
  33. Const CRYPT_EXPORTABLE As Long = 1&
  34. Const CRYPT_NEWKEYSET As Long = 8&
  35. Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
  36. Const CRYPT_DELETEKEYSET As Long = &H10&
  37.  
  38.  
  39.  
  40.  
  41.  
  42. Private Sub Class_Initialize()
  43.  'Try to aquire a handle to the default provider
  44.  result = CryptAcquireContext(hProv, vbNullString, MS_DEF_PROV, PROV_RSA_FULL, 0&)
  45.  If hProv = 0 Then
  46.  'Set the default if needed
  47.  result = CryptSetProvider(MS_DEF_PROV, PROV_RSA_FULL)
  48. APIok (result)
  49.  'Get the handle again
  50.  result = CryptAcquireContext(hProv, vbNullString, MS_DEF_PROV, PROV_RSA_FULL, 0&)
  51. End If
  52. 'Check for key container
  53. If result = 0 And hProv = 0 Then
  54.  'make default key container
  55.  result = CryptAcquireContext(hProv, vbNullString, MS_DEF_PROV, PROV_RSA_FULL, CRYPT_NEWKEYSET)
  56. End If
  57. 'if it isn't ok now give up
  58. APIok (result)
  59. End Sub
  60.  
  61. Public Sub APIok(result As Long)
  62. If result Then Exit Sub
  63. Dim E As Long
  64. E = GetLastError()
  65. Err.Raise vbObjectError + E, "Crypto", "Crypto API error " + Str(E) + " has occured"
  66. End
  67. End Sub
  68.  
  69.  
  70. Public Property Get PassWord() As Variant
  71. PassWord = mPass
  72. End Property
  73.  
  74. Public Property Let PassWord(ByVal vNewValue As Variant)
  75. mPass = vNewValue
  76.  'Create hash object
  77. Dim hHash As Long
  78. result = CryptCreateHash(hProv, CALG_MD5, 0&, 0&, hHash)
  79. APIok (result)
  80. 'convert password string into an array of bytes
  81. Dim datalen As Long
  82. datalen = Len(mPass)
  83. Dim data(100) As Byte
  84. Call CopyStrToByte(mPass, data())
  85. 'hash the password
  86. result = CryptHashData(hHash, data(0), datalen, 0)
  87. APIok (result)
  88. 'delete any existing key
  89. If (hKey <> 0) Then
  90.  result = CryptDestroyKey(hKey)
  91. End If
  92. 'Create session key using hash
  93.     result = CryptDeriveKey(hProv, CALG_RC2, hHash, CRYPT_EXPORTABLE, hKey)
  94.     APIok (result)
  95. 'Destroy hash object
  96.     If (hHash <> 0) Then
  97.      result = CryptDestroyHash(hHash)
  98.     End If
  99. End Property
  100.  
  101.  
  102. Private Sub Class_Terminate()
  103. If (hKey <> 0) Then
  104.  result = CryptDestroyKey(hKey)
  105. End If
  106. If (hProv <> 0) Then
  107.  result = CryptReleaseContext(hProv, 0)
  108. End If
  109. End Sub
  110.  
  111. Public Sub encrypt(Text As String, Final As Boolean)
  112. Dim Count As Long
  113. Count = Len(Text)
  114. 'set up buffer to be larger than string data
  115. ReDim data(Count + 50) As Byte
  116. 'Copy text to buffer
  117.   Call CopyStrToByte(Text, data())
  118. 'Encrypt text
  119.   result = CryptEncrypt(hKey, 0&, Final, 0&, data(0), Count, Count + 50)
  120.   APIok (result)
  121. 'convert buffer to string
  122.  Call CopyByteToStr(data(), Count, Text)
  123. End Sub
  124.  
  125. Public Sub decrypt(Text As String, Final As Boolean)
  126.   Dim Count As Long
  127.   Count = Len(Text)
  128.   ReDim data(Count) As Byte
  129. 'Copy text to buffer
  130.   Call CopyStrToByte(Text, data())
  131. 'Decode
  132. result = CryptDecrypt(hKey, 0&, Final, 0&, data(0), Count)
  133. 'convert buffer to string
  134.  Call CopyByteToStr(data(), Count, Text)
  135. End Sub
  136.  
  137.  
  138. Public Sub CopyStrToByte(a As String, b() As Byte)
  139.  Dim i As Integer
  140. If Len(a) > UBound(b, 1) Then APIok (0)
  141.  For i = 1 To Len(a)
  142.   b(i - 1) = Asc(Mid(a, i, 1))
  143.  Next i
  144. End Sub
  145.  
  146. Public Sub CopyByteToStr(b() As Byte, n As Long, a As String)
  147.  Dim i As Integer
  148.  a = ""
  149.  For i = 1 To n
  150.   a = a & Chr(b(i - 1))
  151.  Next i
  152. End Sub
  153.