Guest User

Untitled

a guest
Jan 11th, 2018
138
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 16.83 KB | None | 0 0
  1. 'Paste this code in a Class Module, named clsCryptoFilterBox
  2.  
  3. Option Explicit
  4.  
  5. Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (phProv As Long, pszContainer As String, pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
  6.  
  7. Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, phHash As Long) As Long
  8.  
  9. Private Declare Function CryptDeriveKey Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hBaseData As Long, ByVal dwFlags As Long, phKey As Long) As Long
  10.  
  11. Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
  12.  
  13. Private Declare Function CryptDestroyKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
  14.  
  15. 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, pdwDataLen As Long, ByVal dwBufLen As Long) As Long
  16.  
  17. 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, pdwDataLen As Long) As Long
  18.  
  19. Private Declare Function CryptExportKey Lib "advapi32.dll" (ByVal hKey As Long, ByVal hExpKey As Long, ByVal dwBlobType As Long, ByVal dwFlags As Long, ByVal pbData As String, pdwDataLen As Long) As Long
  20.  
  21. Private Declare Function CryptGenKey Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal dwFlags As Long, phKey As Long) As Long
  22.  
  23. Private Declare Function CryptGetProvParam Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
  24.  
  25. Private Declare Function CryptGetUserKey Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwKeySpec As Long, phUserKey As Long) As Long
  26.  
  27. 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
  28.  
  29. Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
  30.  
  31. Private Declare Function CryptSignHash Lib "advapi32.dll" Alias "CryptSignHashA" (ByVal hHash As Long, ByVal dwKeySpec As Long, ByVal sDescription As String, ByVal dwFlags As Long, ByVal pbSignature As String, pdwSigLen As Long) As Long
  32.  
  33. Private Declare Function CryptVerifySignature Lib "advapi32.dll" Alias "CryptVerifySignatureA" (ByVal hHash As Long, ByVal pbSignature As String, ByVal dwSigLen As Long, ByVal hPubKey As Long, ByVal sDescription As String, ByVal dwFlags As Long) As Long
  34.  
  35. 'API error function
  36.  
  37. Private Declare Function GetLastError Lib "kernel32" () As Long
  38.  
  39. 'API memory functions
  40.  
  41. Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
  42.  
  43. Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
  44.  
  45. Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  46.  
  47. Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  48.  
  49. Private Declare Sub CpyMemValAdrFromRefAdr Lib "kernel32" Alias "RtlMoveMemory" (ByVal hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
  50.  
  51. Private Declare Sub CpyMemRefAdrFromValAdr Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Any, ByVal cbCopy As Long)
  52.  
  53. 'constants for API memory functions
  54.  
  55. Private Const GMEM_MOVEABLE = &H2
  56.  
  57. Private Const GMEM_ZEROINIT = &H40
  58.  
  59. Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
  60.  
  61. 'constants for Cryptography API functions
  62.  
  63. Private Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"
  64.  
  65. Private Const PROV_RSA_FULL = 1
  66.  
  67. Private Const CRYPT_NEWKEYSET = &H8
  68.  
  69. Private Const PP_CONTAINER = 6
  70.  
  71. Private Const AT_KEYEXCHANGE = 1
  72.  
  73. Private Const AT_SIGNATURE = 2
  74.  
  75. Private Const SIMPLEBLOB = 1
  76.  
  77. Private Const ALG_CLASS_DATA_ENCRYPT = 24576
  78.  
  79. Private Const ALG_CLASS_HASH = 32768
  80.  
  81. Private Const ALG_TYPE_ANY = 0
  82.  
  83. Private Const ALG_TYPE_BLOCK = 1536
  84.  
  85. Private Const ALG_TYPE_STREAM = 2048
  86.  
  87. Private Const ALG_SID_RC2 = 2
  88.  
  89. Private Const ALG_SID_RC4 = 1
  90.  
  91. Private Const ALG_SID_MD5 = 3
  92.  
  93. Private Const CALG_MD5 = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
  94.  
  95. Private Const CALG_RC2 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK) Or ALG_SID_RC2)
  96.  
  97. Private Const CALG_RC4 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)
  98.  
  99. 'constants from WinErr.h
  100.  
  101. Private Const NTE_NO_KEY As Long = -2146893811 '0x8009000DL
  102.  
  103. Private Const NTE_BAD_SIGNATURE As Long = -2146893818
  104.  
  105. 'clsCryptoFilterBox constants
  106.  
  107. Private Const CFB_BUSY = 0
  108.  
  109. Private Const CFB_READY = 1
  110.  
  111. Private Const CFB_VALID = 2
  112.  
  113. Private Const ENCRYPT_ALGORITHM = CALG_RC4
  114.  
  115. Private Const ENCRYPT_BLOCK_SIZE = 1
  116.  
  117. Private Const CRYPT_EXPORTABLE = 1
  118.  
  119. 'private property buffers
  120.  
  121. Private sInBuffer As String
  122.  
  123. Private sOutBuffer As String
  124.  
  125. Private sPassword As String
  126.  
  127. Private sSignature As String
  128.  
  129. Private lStatus As Long
  130.  
  131. Public Property Get InBuffer() As String
  132.  
  133. InBuffer = sInBuffer
  134.  
  135. End Property
  136.  
  137. Public Property Let InBuffer(vNewValue As String)
  138.  
  139. sInBuffer = vNewValue
  140.  
  141. End Property
  142.  
  143. Public Property Get OutBuffer() As String
  144.  
  145. OutBuffer = sOutBuffer
  146.  
  147. End Property
  148.  
  149. Public Property Get Signature() As String
  150.  
  151. Signature = sSignature
  152.  
  153. End Property
  154.  
  155. Public Property Let Signature(vNewValue As String)
  156.  
  157. sSignature = vNewValue
  158.  
  159. End Property
  160.  
  161. Public Sub Sign()
  162.  
  163. 'Create a signature for Inbuffer and place in Signature
  164.  
  165. Dim sContainer As String, sDescription As String, sProvider As String, lHCryptprov As Long
  166.  
  167. Dim lHHash As Long, lResult As Long, lSignatureLen As Long
  168.  
  169. On Error GoTo ErrSign
  170.  
  171. 'switch Status property
  172.  
  173. lStatus = CFB_BUSY
  174.  
  175. 'init Signature property
  176.  
  177. sSignature = ""
  178.  
  179. 'Get handle to the default provider.
  180.  
  181. sContainer = vbNullChar
  182.  
  183. sProvider = MS_DEF_PROV & vbNullChar
  184.  
  185. If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then
  186.  
  187. MsgBox ("Error " & CStr(GetLastError) & " during CryptAcquireContext!")
  188.  
  189. GoTo ReleaseHandles:
  190.  
  191. End If
  192.  
  193. 'Create a hash object.
  194.  
  195. If Not CBool(CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash)) Then
  196.  
  197. MsgBox ("Error " & CStr(GetLastError) & " during CryptCreateHash!")
  198.  
  199. GoTo ReleaseHandles:
  200.  
  201. End If
  202.  
  203. If Not CBool(CryptHashData(lHHash, sInBuffer, Len(sInBuffer), 0)) Then
  204.  
  205. MsgBox ("Error " & CStr(GetLastError) & " during CryptHashData!")
  206.  
  207. GoTo ReleaseHandles:
  208.  
  209. End If
  210.  
  211. 'Sign hash object.
  212.  
  213. 'Determine size of signature.
  214.  
  215. sDescription = vbNullChar
  216.  
  217. lResult = CryptSignHash(lHHash, AT_SIGNATURE, sDescription, 0, sSignature, lSignatureLen)
  218.  
  219. sSignature = String(lSignatureLen, vbNullChar)
  220.  
  221. 'Sign hash object (with signature key).
  222.  
  223. If Not CBool(CryptSignHash(lHHash, AT_SIGNATURE, sDescription, 0, sSignature, lSignatureLen)) Then
  224.  
  225. MsgBox ("Error " & CStr(GetLastError()) & " during CryptSignHash")
  226.  
  227. GoTo ReleaseHandles:
  228.  
  229. End If
  230.  
  231. ReleaseHandles:
  232.  
  233. 'Destroy hash object.
  234.  
  235. If lHHash Then lResult = CryptDestroyHash(lHHash)
  236.  
  237. 'Release provider handle.
  238.  
  239. If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)
  240.  
  241. 'switch Status property
  242.  
  243. lStatus = CFB_READY
  244.  
  245. Exit Sub
  246.  
  247. ErrSign:
  248.  
  249. MsgBox ("ErrSign " & Error$)
  250.  
  251. GoTo ReleaseHandles
  252.  
  253. End Sub
  254.  
  255. Public Sub Validate()
  256.  
  257. 'Validate InBuffer with Signature and assign Status with result
  258.  
  259. Dim bValid As Boolean, sContainer As String, sDescription As String, sProvider As String
  260.  
  261. Dim lDataLen As Long, lDataPoint As Long, lHCryptprov As Long, lHHash As Long
  262.  
  263. Dim lResult As Long, lSignatureLen As Long, lHCryptKey As Long
  264.  
  265. ReDim aByteData(0) As Byte
  266.  
  267. On Error GoTo ErrValidate
  268.  
  269. 'switch Status property
  270.  
  271. lStatus = CFB_BUSY
  272.  
  273. 'init internal valid flag
  274.  
  275. bValid = True
  276.  
  277. 'Get handle to the default provider.
  278.  
  279. sContainer = vbNullChar
  280.  
  281. sProvider = MS_DEF_PROV & vbNullChar
  282.  
  283. If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then
  284.  
  285. bValid = False
  286.  
  287. MsgBox ("Error " & CStr(GetLastError) & " during CryptAcquireContext!")
  288.  
  289. GoTo ReleaseHandles:
  290.  
  291. End If
  292.  
  293. 'Create a hash object.
  294.  
  295. If Not CBool(CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash)) Then
  296.  
  297. bValid = False
  298.  
  299. MsgBox ("Error " & CStr(GetLastError) & " during CryptCreateHash!")
  300.  
  301. GoTo ReleaseHandles:
  302.  
  303. End If
  304.  
  305. 'Add data to hash object.
  306.  
  307. If Not CBool(CryptHashData(lHHash, sInBuffer, Len(sInBuffer), 0)) Then
  308.  
  309. bValid = False
  310.  
  311. MsgBox ("Error " & CStr(GetLastError) & " during CryptHashData!")
  312.  
  313. GoTo ReleaseHandles:
  314.  
  315. End If
  316.  
  317. 'Determine size of signature.
  318.  
  319. 'sDescription = vbNullChar
  320.  
  321. 'lResult = CryptSignHash(lHHash, AT_SIGNATURE, sDescription, 0, 0, lSignatureLen)
  322.  
  323. 'Get handle to signature key.
  324.  
  325. If Not CBool(CryptGetUserKey(lHCryptprov, AT_SIGNATURE, lHCryptKey)) Then
  326.  
  327. bValid = False
  328.  
  329. MsgBox ("Error " & CStr(GetLastError) & " during CryptGetUserKey!")
  330.  
  331. GoTo ReleaseHandles:
  332.  
  333. End If
  334.  
  335. lSignatureLen = Len(sSignature)
  336.  
  337. 'Verify signature.
  338.  
  339. If Not CBool(CryptVerifySignature(lHHash, sSignature, lSignatureLen, lHCryptKey, sDescription, 0)) Then
  340.  
  341. If GetLastError = NTE_BAD_SIGNATURE Then
  342.  
  343. bValid = False
  344.  
  345. GoTo ReleaseHandles:
  346.  
  347. Else
  348.  
  349. bValid = False
  350.  
  351. MsgBox ("Error " & CStr(GetLastError) & " during CryptVerifySignature!")
  352.  
  353. GoTo ReleaseHandles:
  354.  
  355. End If
  356.  
  357. End If
  358.  
  359. ReleaseHandles:
  360.  
  361. 'Release signature key.
  362.  
  363. If lHCryptKey Then lResult = CryptDestroyKey(lHCryptKey)
  364.  
  365. 'Destroy hash object.
  366.  
  367. If lHHash Then lResult = CryptDestroyHash(lHHash)
  368.  
  369. 'Release provider handle.
  370.  
  371. If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)
  372.  
  373. Select Case bValid
  374.  
  375. Case True
  376.  
  377. lStatus = CFB_VALID
  378.  
  379. Case Else
  380.  
  381. lStatus = CFB_READY
  382.  
  383. End Select
  384.  
  385. Exit Sub
  386.  
  387. ErrValidate:
  388.  
  389. MsgBox ("ErrValidate " & Error$)
  390.  
  391. Resume
  392.  
  393. End Sub
  394.  
  395. Public Sub Encrypt()
  396.  
  397. 'Encrypt InBuffer into OutBuffer
  398.  
  399. Dim lHExchgKey As Long, lHCryptprov As Long, lHHash As Long, lHkey As Long
  400.  
  401. Dim lResult As Long, sContainer As String, sProvider As String, sCryptBuffer As String
  402.  
  403. Dim lCryptLength As Long, lCryptBufLen As Long
  404.  
  405. On Error GoTo ErrEncrypt
  406.  
  407. 'switch Status property
  408.  
  409. lStatus = CFB_BUSY
  410.  
  411. 'Get handle to the default provider
  412.  
  413. sContainer = vbNullChar
  414.  
  415. sProvider = vbNullChar
  416.  
  417. sProvider = MS_DEF_PROV & vbNullChar
  418.  
  419. If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then
  420.  
  421. MsgBox ("Error " & CStr(GetLastError) & " during CryptAcquireContext!")
  422.  
  423. GoTo Done
  424.  
  425. End If
  426.  
  427. 'Create a hash object.
  428.  
  429. If Not CBool(CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash)) Then
  430.  
  431. MsgBox ("Error " & CStr(GetLastError) & " during CryptCreateHash!")
  432.  
  433. GoTo Done
  434.  
  435. End If
  436.  
  437. 'Hash in the password data.
  438.  
  439. If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then
  440.  
  441. MsgBox ("Error " & CStr(GetLastError) & " during CryptHashData!")
  442.  
  443. GoTo Done
  444.  
  445. End If
  446.  
  447. 'Derive a session key from the hash object.
  448.  
  449. If Not CBool(CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, 0, lHkey)) Then
  450.  
  451. MsgBox ("Error " & CStr(GetLastError) & " during CryptDeriveKey!")
  452.  
  453. GoTo Done
  454.  
  455. End If
  456.  
  457. 'Destroy the hash object.
  458.  
  459. CryptDestroyHash (lHHash)
  460.  
  461. lHHash = 0
  462.  
  463. 'Prepare a string buffer for the CryptEncrypt function
  464.  
  465. lCryptLength = Len(sInBuffer)
  466.  
  467. lCryptBufLen = lCryptLength * 2
  468.  
  469. sCryptBuffer = String(lCryptBufLen, vbNullChar)
  470.  
  471. LSet sCryptBuffer = sInBuffer
  472.  
  473. 'Encrypt data
  474.  
  475. If Not CBool(CryptEncrypt(lHkey, 0, 1, 0, sCryptBuffer, lCryptLength, lCryptBufLen)) Then
  476.  
  477. MsgBox ("bytes required:" & CStr(lCryptLength))
  478.  
  479. MsgBox ("Error " & CStr(GetLastError) & " during CryptEncrypt!")
  480.  
  481. 'GoTo Done
  482.  
  483. End If
  484.  
  485. sOutBuffer = Mid$(sCryptBuffer, 1, lCryptLength)
  486.  
  487. Done:
  488.  
  489. 'Destroy session key.
  490.  
  491. If (lHkey) Then lResult = CryptDestroyKey(lHkey)
  492.  
  493. 'Release key exchange key handle.
  494.  
  495. If lHExchgKey Then CryptDestroyKey (lHExchgKey)
  496.  
  497. 'Destroy hash object.
  498.  
  499. If lHHash Then CryptDestroyHash (lHHash)
  500.  
  501. 'Release provider handle.
  502.  
  503. If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)
  504.  
  505. 'switch Status property
  506.  
  507. lStatus = CFB_READY
  508.  
  509. Exit Sub
  510.  
  511. ErrEncrypt:
  512.  
  513. MsgBox ("ErrEncrypt " & Error$)
  514.  
  515. Resume
  516.  
  517. End Sub
  518.  
  519. Public Sub Decrypt()
  520.  
  521. 'Decrypt InBuffer into OutBuffer
  522.  
  523. Dim lHExchgKey As Long, lHCryptprov As Long, lHHash As Long, lHkey As Long
  524.  
  525. Dim lResult As Long, sContainer As String, sProvider As String
  526.  
  527. Dim sCryptBuffer As String, lCryptBufLen As Long, lCryptPoint As Long
  528.  
  529. Dim lPasswordPoint As Long, lPasswordCount As Long
  530.  
  531. On Error GoTo ErrDecrypt
  532.  
  533. 'switch Status property
  534.  
  535. lStatus = CFB_BUSY
  536.  
  537. 'Init sOutBuffer
  538.  
  539. sOutBuffer = ""
  540.  
  541. 'Get handle to the default provider.
  542.  
  543. sContainer = vbNullChar
  544.  
  545. sProvider = vbNullChar
  546.  
  547. sProvider = MS_DEF_PROV & vbNullChar
  548.  
  549. If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then
  550.  
  551. MsgBox ("Error " & CStr(GetLastError) & " during CryptAcquireContext!")
  552.  
  553. GoTo Done
  554.  
  555. End If
  556.  
  557. 'Create a hash object.
  558.  
  559. If Not CBool(CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash)) Then
  560.  
  561. MsgBox ("Error " & CStr(GetLastError) & " during CryptCreateHash!")
  562.  
  563. GoTo Done
  564.  
  565. End If
  566.  
  567. 'Hash in the password data.
  568.  
  569. If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then
  570.  
  571. MsgBox ("Error " & CStr(GetLastError) & " during CryptHashData!")
  572.  
  573. GoTo Done
  574.  
  575. End If
  576.  
  577. 'Derive a session key from the hash object.
  578.  
  579. If Not CBool(CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, 0, lHkey)) Then
  580.  
  581. MsgBox ("Error " & CStr(GetLastError) & " during CryptDeriveKey!")
  582.  
  583. GoTo Done
  584.  
  585. End If
  586.  
  587. 'Destroy the hash object.
  588.  
  589. CryptDestroyHash (lHHash)
  590.  
  591. lHHash = 0
  592.  
  593. 'Prepare sCryptBuffer for CryptDecrypt
  594.  
  595. lCryptBufLen = Len(sInBuffer) * 2
  596.  
  597. sCryptBuffer = String(lCryptBufLen, vbNullChar)
  598.  
  599. LSet sCryptBuffer = sInBuffer
  600.  
  601. 'Decrypt data
  602.  
  603. If Not CBool(CryptDecrypt(lHkey, 0, 1, 0, sCryptBuffer, lCryptBufLen)) Then
  604.  
  605. MsgBox ("bytes required:" & CStr(lCryptBufLen))
  606.  
  607. MsgBox ("Error " & CStr(GetLastError) & " during CryptDecrypt!")
  608.  
  609. GoTo Done
  610.  
  611. End If
  612.  
  613. 'Apply decrypted string from sCryptBuffer to private buffer for OutBuffer property
  614.  
  615. sOutBuffer = Mid$(sCryptBuffer, 1, Len(sInBuffer))
  616.  
  617. Done:
  618.  
  619. 'Destroy session key.
  620.  
  621. If (lHkey) Then lResult = CryptDestroyKey(lHkey)
  622.  
  623. 'Release key exchange key handle.
  624.  
  625. If lHExchgKey Then CryptDestroyKey (lHExchgKey)
  626.  
  627. 'Destroy hash object.
  628.  
  629. If lHHash Then CryptDestroyHash (lHHash)
  630.  
  631. 'Release provider handle.
  632.  
  633. If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)
  634.  
  635. 'switch Status property
  636.  
  637. lStatus = CFB_READY
  638.  
  639. Exit Sub
  640.  
  641. ErrDecrypt:
  642.  
  643. MsgBox ("ErrDecrypt " & Error$)
  644.  
  645. GoTo Done
  646.  
  647. End Sub
  648.  
  649. Public Property Get Status() As Long
  650.  
  651. Status = lStatus
  652.  
  653. End Property
  654.  
  655. Private Function InitUser() As Long
  656.  
  657. Dim lHCryptprov As Long, lHCryptKey As Long, avProviderData(1000) As Byte
  658.  
  659. Dim lProviderDataAddress As Long, lProviderDataLen As Long, lDataSize As Long
  660.  
  661. Dim lResult As Long, sContainer As String, sProvider As String
  662.  
  663. Dim sUserName As String, lPoint As Long, lMemHandle As Long
  664.  
  665. Dim lReturn As Long, sBuffer As String
  666.  
  667. On Error GoTo ErrInitUser
  668.  
  669. 'prepare string buffers
  670.  
  671. sContainer = vbNullChar
  672.  
  673. sProvider = MS_DEF_PROV & vbNullChar
  674.  
  675. 'Attempt to acquire a handle to the default key container.
  676.  
  677. If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then
  678.  
  679. 'Create default key container.
  680.  
  681. If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
  682.  
  683. MsgBox ("Error creating key container! " & CStr(GetLastError))
  684.  
  685. Exit Function
  686.  
  687. End If
  688.  
  689. 'Get name of default key container.
  690.  
  691. lProviderDataLen = Len(avProviderData(0)) * (UBound(avProviderData) + 1)
  692.  
  693. If Not CBool(CryptGetProvParam(lHCryptprov, PP_CONTAINER, avProviderData(0), lProviderDataLen, 0)) Then
  694.  
  695. MsgBox ("Error getting user name! " & CStr(GetLastError))
  696.  
  697. avProviderData(0) = 0
  698.  
  699. End If
  700.  
  701. 'Get sUserName from avProviderData()
  702.  
  703. lPoint = LBound(avProviderData)
  704.  
  705. While lPoint <= UBound(avProviderData)
  706.  
  707. If avProviderData(lPoint) <> 0 Then
  708.  
  709. sUserName = sUserName & Chr$(avProviderData(lPoint))
  710.  
  711. Else
  712.  
  713. lPoint = UBound(avProviderData)
  714.  
  715. End If
  716.  
  717. lPoint = lPoint + 1
  718.  
  719. Wend
  720.  
  721. MsgBox ("Create key container " & sUserName)
  722.  
  723. End If
  724.  
  725. 'Attempt to get handle to signature key
  726.  
  727. If Not CBool(CryptGetUserKey(lHCryptprov, AT_SIGNATURE, lHCryptKey)) Then
  728.  
  729. If GetLastError = NTE_NO_KEY Then
  730.  
  731. MsgBox ("Create key exchange key pair")
  732.  
  733. If Not CBool(CryptGenKey(lHCryptprov, AT_SIGNATURE, 0, lHCryptKey)) Then
  734.  
  735. MsgBox ("Error during CryptGenKey! " & CStr(GetLastError))
  736.  
  737. Exit Function
  738.  
  739. Else
  740.  
  741. lResult = CryptDestroyKey(lHCryptprov)
  742.  
  743. End If
  744.  
  745. Else
  746.  
  747. MsgBox ("Error during CryptGetUserKey! " & CStr(GetLastError))
  748.  
  749. Exit Function
  750.  
  751. End If
  752.  
  753. End If
  754.  
  755. 'Attempt to get handle to exchange key
  756.  
  757. If Not CBool(CryptGetUserKey(lHCryptprov, AT_KEYEXCHANGE, lHCryptKey)) Then
  758.  
  759. If GetLastError = NTE_NO_KEY Then
  760.  
  761. MsgBox ("Create key exchange key pair")
  762.  
  763. If Not CBool(CryptGenKey(lHCryptprov, AT_KEYEXCHANGE, 0, lHCryptKey)) Then
  764.  
  765. MsgBox ("Error during CryptGenKey! " & CStr(GetLastError))
  766.  
  767. Exit Function
  768.  
  769. Else
  770.  
  771. lResult = CryptDestroyKey(lHCryptprov)
  772.  
  773. End If
  774.  
  775. Else
  776.  
  777. MsgBox ("Error during CryptGetUserKey! " & CStr(GetLastError))
  778.  
  779. Exit Function
  780.  
  781. End If
  782.  
  783. End If
  784.  
  785. 'release handle to provider
  786.  
  787. lResult = CryptReleaseContext(lHCryptprov, 0)
  788.  
  789. InitUser = True
  790.  
  791. Exit Function
  792.  
  793. ErrInitUser:
  794.  
  795. MsgBox ("ErrInitUser " & Error$)
  796.  
  797. Resume
  798.  
  799. End Function
  800.  
  801. Private Sub Class_Initialize()
  802.  
  803. If InitUser = True Then
  804.  
  805. MsgBox ("InitUser OK")
  806.  
  807. Else
  808.  
  809. MsgBox ("InitUser failed")
  810.  
  811. End If
  812.  
  813. End Sub
  814.  
  815. Public Property Get Password() As String
  816.  
  817. Password = sPassword
  818.  
  819. End Property
  820.  
  821. Public Property Let Password(vNewValue As String)
  822.  
  823. sPassword = vNewValue
  824.  
  825. End Property
Add Comment
Please, Sign In to add comment