Option Compare Database
Option Explicit


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

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

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

Private Declare Function CryptDestroyHash Lib  "advapi32.dll"  _
                                          (ByVal hHash As Long) As Long

Private Declare Function CryptDestroyKey Lib  "advapi32.dll"  _
                                         (ByVal hKey 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, _
                                       pdwDataLen As Long, _
                                       ByVal dwBufLen 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, _
                                       pdwDataLen As Long) As Long

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

Private Declare Function CryptGenKey Lib  "advapi32.dll"  _
                                     (ByVal hProv As Long, _
                                      ByVal Algid As Long, _
                                      ByVal dwFlags As Long, _
                                      phKey As Long) As Long

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

Private Declare Function CryptGetUserKey Lib  "advapi32.dll"  _
                                         (ByVal hProv As Long, _
                                          ByVal dwKeySpec As Long, _
                                          phUserKey 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 CryptReleaseContext Lib  "advapi32.dll"  _
                                             (ByVal hProv As Long, _
                                              ByVal dwFlags As Long) As Long

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

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

Private Declare Function GetLastError Lib  "kernel32"  () As Long

Private Declare Function GlobalAlloc Lib  "kernel32"  _
                                     (ByVal wFlags As Long, _
                                      ByVal dwBytes As Long) As Long

Private Declare Function GlobalFree Lib  "kernel32"  _
                                    (ByVal hMem As Long) As Long

Private Declare Function GlobalLock Lib  "kernel32"  _
                                    (ByVal hMem As Long) As Long

Private Declare Function GlobalUnlock Lib  "kernel32"  _
                                      (ByVal hMem As Long) As Long

Private Declare Sub CpyMemValAdrFromRefAdr Lib  "kernel32"  _
                                           Alias  "RtlMoveMemory"  _
                                           (ByVal hpvDest As Any, _
                                            hpvSource As Any, _
                                            ByVal cbCopy As Long)

Private Declare Sub CpyMemRefAdrFromValAdr Lib  "kernel32"  _
                                           Alias  "RtlMoveMemory"  _
                                           (hpvDest As Any, _
                                            ByVal hpvSource As Any, _
                                            ByVal cbCopy As Long)

Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

Private Const MS_DEF_PROV =  "Microsoft Base"  & _
         " Cryptographic Provider v1.0 "
''Note: Don’t let the v1. 0  in the name fool you as it fooled me. To find the real version, call the CSP’s CryptGetProvParam() function. The CSP name is a unique identifier of the CSP (it’s the key value of a registry call to look up the other pertinent information). If Microsoft changed the name when they changed the version, it wouldn’t be backward compatible with old programs that are looking for the old version in the Registry. Whoops! Someone’s underwear is hanging out in plain sight of the entire world. No serious criticism–I’ve made a few of those mistakes in my day, too
        
Private Const PROV_RSA_FULL =  1 
Private Const CRYPT_NEWKEYSET = &H8
Private Const PP_CONTAINER =  6 
Private Const AT_KEYEXCHANGE =  1 
Private Const AT_SIGNATURE =  2 

Private Const SIMPLEBLOB =  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 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 NTE_NO_KEY           As Long = - 2146893811     '0x8009000DL
Private Const NTE_BAD_SIGNATURE    As Long = -2146893818

Private Const CFB_BUSY = 0
Private Const CFB_READY = 1
Private Const CFB_VALID = 2

Private Const ENCRYPT_ALGORITHM = CALG_RC4
Private Const ENCRYPT_BLOCK_SIZE = 1

Private Const CRYPT_EXPORTABLE = 1

Private sInBuffer                  As String
Private sOutBuffer                 As String
Private sPassword                  As String
Private sSignature                 As String
Private lStatus                    As Long

Public Property Get InBuffer() As String
    InBuffer = sInBuffer
End Property

Public Property Let InBuffer(vNewValue As String)
    sInBuffer = vNewValue
End Property

Public Property Get OutBuffer() As String
    OutBuffer = sOutBuffer
End Property

Public Property Get Signature() As String
    Signature = sSignature
End Property

Public Property Let Signature(vNewValue As String)
    sSignature = vNewValue
End Property

Public Sub Sign()

    Dim sContainer                 As String
    Dim sDescription               As String
    Dim sProvider                  As String
    Dim lHCryptprov                As Long
    Dim lHHash                     As Long
    Dim lResult                    As Long
    Dim lSignatureLen              As Long

    On Error GoTo ErrSign

    lStatus = CFB_BUSY

    sSignature = ""

    sContainer = vbNullChar
    sProvider = MS_DEF_PROV & vbNullChar
    If Not CBool(CryptAcquireContext(lHCryptprov, _
                 ByVal sContainer, _
                 ByVal sProvider, _
                 PROV_RSA_FULL, 0)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptAcquireContext!")
        GoTo ReleaseHandles:
    End If

    If Not CBool(CryptCreateHash(lHCryptprov, _
                 CALG_MD5, 0, 0, lHHash)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptCreateHash!")
        GoTo ReleaseHandles:
    End If

    If Not CBool(CryptHashData(lHHash, sInBuffer, _
                 Len(sInBuffer), 0)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptHashData!")
        GoTo ReleaseHandles:
    End If

    sDescription = vbNullChar
    lResult = CryptSignHash(lHHash, AT_SIGNATURE, _
                            sDescription, 0, sSignature, _
                            lSignatureLen)

    sSignature = String(lSignatureLen, vbNullChar)

    If Not CBool(CryptSignHash(lHHash, AT_SIGNATURE, sDescription, _
                 0, sSignature, lSignatureLen)) Then
        MsgBox ("Error " & CStr(GetLastError()) & _
                " during CryptSignHash")
        GoTo ReleaseHandles:
    End If

ReleaseHandles:
    If lHHash Then lResult = CryptDestroyHash(lHHash)
    If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)

    lStatus = CFB_READY

    Exit Sub

ErrSign:
    MsgBox ("ErrSign " & Error$)
    GoTo ReleaseHandles
End Sub

Public Sub Validate()

    Dim bValid                     As Boolean
    Dim sContainer                 As String
    Dim sDescription               As String
    Dim sProvider                  As String
    Dim lDataLen                   As Long
    Dim lDataPoint                 As Long
    Dim lHCryptprov                As Long
    Dim lHHash                     As Long
    Dim lResult                    As Long
    Dim lSignatureLen              As Long
    Dim lHCryptKey                 As Long

    ReDim aByteData(0) As Byte

    On Error GoTo ErrValidate

    lStatus = CFB_BUSY

    bValid = True

    sContainer = vbNullChar
    sProvider = MS_DEF_PROV & vbNullChar
    If Not CBool(CryptAcquireContext(lHCryptprov, _
                 ByVal sContainer, ByVal sProvider, _
                 PROV_RSA_FULL, 0)) Then
        bValid = False
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptAcquireContext!")
        GoTo ReleaseHandles:
    End If

    If Not CBool(CryptCreateHash(lHCryptprov, _
                 CALG_MD5, 0, 0, lHHash)) Then
        bValid = False
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptCreateHash!")
        GoTo ReleaseHandles:
    End If

    If Not CBool(CryptHashData(lHHash, sInBuffer, _
                 Len(sInBuffer), 0)) Then
        bValid = False
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptHashData!")
        GoTo ReleaseHandles:
    End If

    If Not CBool(CryptGetUserKey(lHCryptprov, _
                 AT_SIGNATURE, lHCryptKey)) Then
        bValid = False
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptGetUserKey!")
        GoTo ReleaseHandles:
    End If

    lSignatureLen = Len(sSignature)

    If Not CBool(CryptVerifySignature(lHHash, sSignature, _
                 lSignatureLen, lHCryptKey, _
                 sDescription, 0)) Then

        If GetLastError = NTE_BAD_SIGNATURE Then
            bValid = False
            GoTo ReleaseHandles:
        Else
            bValid = False
            MsgBox ("Error " & CStr(GetLastError) & _
                    " during CryptVerifySignature!")
            GoTo ReleaseHandles:
        End If

    End If

ReleaseHandles:
    If lHCryptKey Then lResult = CryptDestroyKey(lHCryptKey)
    If lHHash Then lResult = CryptDestroyHash(lHHash)
    If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)

    Select Case bValid
        Case True
            lStatus = CFB_VALID
        Case Else
            lStatus = CFB_READY
    End Select

    Exit Sub

ErrValidate:
    MsgBox ("ErrValidate " & Error$)
    Resume

End Sub

Public Sub Encrypt()

    Dim lHExchgKey                 As Long
    Dim lHCryptprov                As Long
    Dim lHHash                     As Long
    Dim lHkey                      As Long
    Dim lResult                    As Long
    Dim sContainer                 As String
    Dim sProvider                  As String
    Dim sCryptBuffer               As String
    Dim lCryptLength               As Long
    Dim lCryptBufLen               As Long

    On Error GoTo ErrEncrypt

    lStatus = CFB_BUSY

    sContainer = vbNullChar
    sProvider = vbNullChar
    sProvider = MS_DEF_PROV & vbNullChar
    If Not CBool(CryptAcquireContext(lHCryptprov, _
                 ByVal sContainer, _
                 ByVal sProvider, _
                 PROV_RSA_FULL, 0)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptAcquireContext!")
        GoTo Done
    End If

    If Not CBool(CryptCreateHash(lHCryptprov, _
                 CALG_MD5, 0, 0, lHHash)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptCreateHash!")
        GoTo Done
    End If

    If Not CBool(CryptHashData(lHHash, sPassword, _
                 Len(sPassword), 0)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptHashData!")
        GoTo Done
    End If

    If Not CBool(CryptDeriveKey(lHCryptprov, _
                 ENCRYPT_ALGORITHM, _
                 lHHash, 0, lHkey)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptDeriveKey!")
        GoTo Done
    End If

    CryptDestroyHash (lHHash)
    lHHash = 0

    lCryptLength = Len(sInBuffer)
    lCryptBufLen = lCryptLength * 2
    sCryptBuffer = String(lCryptBufLen, vbNullChar)
    LSet sCryptBuffer = sInBuffer

    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

    sOutBuffer = Mid$(sCryptBuffer, 1, lCryptLength)

Done:

    If (lHkey) Then lResult = CryptDestroyKey(lHkey)

    If lHExchgKey Then CryptDestroyKey (lHExchgKey)

    If lHHash Then CryptDestroyHash (lHHash)

    If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)

    lStatus = CFB_READY

    Exit Sub

ErrEncrypt:

    MsgBox ("ErrEncrypt " & Error$)
    Resume

End Sub

Public Sub Decrypt()

    Dim lHExchgKey                 As Long
    Dim lHCryptprov                As Long
    Dim lHHash                     As Long
    Dim lHkey                      As Long
    Dim lResult                    As Long
    Dim sContainer                 As String
    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 ErrDecrypt

    lStatus = CFB_BUSY

    sOutBuffer = ""

    sContainer = vbNullChar
    sProvider = vbNullChar
    sProvider = MS_DEF_PROV & vbNullChar
    If Not CBool(CryptAcquireContext(lHCryptprov, _
                 ByVal sContainer, _
                 ByVal sProvider, _
                 PROV_RSA_FULL, 0)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptAcquireContext!")
        GoTo Done
    End If

    If Not CBool(CryptCreateHash(lHCryptprov, _
                 CALG_MD5, 0, 0, lHHash)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptCreateHash!")
        GoTo Done
    End If

    If Not CBool(CryptHashData(lHHash, sPassword, _
                 Len(sPassword), 0)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptHashData!")
        GoTo Done
    End If

    If Not CBool(CryptDeriveKey(lHCryptprov, _
                 ENCRYPT_ALGORITHM, _
                 lHHash, 0, lHkey)) Then
        MsgBox ("Error " & CStr(GetLastError) & _
                " during CryptDeriveKey!")
        GoTo Done
    End If

    CryptDestroyHash (lHHash)
    lHHash = 0

    lCryptBufLen = Len(sInBuffer) * 2
    sCryptBuffer = String(lCryptBufLen, vbNullChar)
    LSet sCryptBuffer = sInBuffer

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

    sOutBuffer = Mid$(sCryptBuffer, 1, Len(sInBuffer))

Done:

    If (lHkey) Then lResult = CryptDestroyKey(lHkey)

    If lHExchgKey Then CryptDestroyKey (lHExchgKey)

    If lHHash Then CryptDestroyHash (lHHash)

    If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)

    lStatus = CFB_READY

    Exit Sub

ErrDecrypt:
    MsgBox ("ErrDecrypt " & Error$)
    GoTo Done

End Sub

Public Property Get Status() As Long
    Status = lStatus
End Property

Private Function InitUser() As Long
    Dim lHCryptprov                As Long
    Dim lHCryptKey                 As Long
    Dim avProviderData(1000)       As Byte
    Dim lProviderDataAddress       As Long
    Dim lProviderDataLen           As Long
    Dim lDataSize                  As Long
    Dim lResult                    As Long
    Dim sContainer                 As String
    Dim sProvider                  As String
    Dim sUserName                  As String
    Dim lPoint                     As Long
    Dim lMemHandle                 As Long
    Dim lReturn                    As Long
    Dim sBuffer                    As String

    On Error GoTo ErrInitUser

    sContainer = vbNullChar
    sProvider = MS_DEF_PROV & vbNullChar

    If Not CBool(CryptAcquireContext(lHCryptprov, _
                 ByVal sContainer, _
                 ByVal sProvider, PROV_RSA_FULL, 0)) Then

        If Not CBool(CryptAcquireContext(lHCryptprov, _
                     ByVal sContainer, _
                     ByVal sProvider, _
                     PROV_RSA_FULL, _
                     CRYPT_NEWKEYSET)) Then
            MsgBox ("Error creating key container! " & _
                    CStr(GetLastError))
            Exit Function
        End If

        lProviderDataLen = Len(avProviderData(0)) * _
                           (UBound(avProviderData) + 1)
        If Not CBool(CryptGetProvParam(lHCryptprov, _
                     PP_CONTAINER, avProviderData(0), _
                     lProviderDataLen, 0)) Then
            MsgBox ("Error getting user name! " & CStr(GetLastError))
            avProviderData(0) = 0
        End If

        lPoint = LBound(avProviderData)
        While lPoint <= UBound(avProviderData)
            If avProviderData(lPoint) <> 0 Then
                sUserName = sUserName & Chr$(avProviderData(lPoint))
            Else
                lPoint = UBound(avProviderData)
            End If
            lPoint = lPoint + 1
        Wend

        MsgBox ("Create key container " & sUserName)

    End If

    If Not CBool(CryptGetUserKey(lHCryptprov, _
                 AT_SIGNATURE, _
                 lHCryptKey)) Then
        If GetLastError = NTE_NO_KEY Then
            MsgBox ("Create key exchange key pair")
            If Not CBool(CryptGenKey(lHCryptprov, _
                         AT_SIGNATURE, 0, _
                         lHCryptKey)) Then
                MsgBox ("Error during CryptGenKey! " & _
                        CStr(GetLastError))
                Exit Function
            Else
                lResult = CryptDestroyKey(lHCryptprov)
            End If
        Else
            MsgBox ("Error during CryptGetUserKey! " & _
                    CStr(GetLastError))
            Exit Function
        End If
    End If

    If Not CBool(CryptGetUserKey(lHCryptprov, _
                 AT_KEYEXCHANGE, lHCryptKey)) Then
        If GetLastError = NTE_NO_KEY Then
            MsgBox ("Create key exchange key pair")
            If Not CBool(CryptGenKey(lHCryptprov, _
                         AT_KEYEXCHANGE, 0, lHCryptKey)) Then
                MsgBox ("Error during CryptGenKey! " & _
                        CStr(GetLastError))
                Exit Function
            Else
                lResult = CryptDestroyKey(lHCryptprov)
            End If
        Else
            MsgBox ("Error during CryptGetUserKey! " & _
                    CStr(GetLastError))
            Exit Function
        End If
    End If

    lResult = CryptReleaseContext(lHCryptprov, 0)
    InitUser = True

    Exit Function

ErrInitUser:
    MsgBox ("ErrInitUser " & Error$)
    Resume

End Function

Private Sub Class_Initialize()
    If InitUser = True Then
        '        MsgBox ( "InitUser OK" )
    Else
        MsgBox ( "InitUser failed. " )
    End If
End Sub

Public Property Get Password() As String
    Password = sPassword
End Property

Public Property Let Password(vNewValue As String)
    sPassword = vNewValue
End Property

    Dim t                          As New clsCryptoAPI
    '**************шифруем
    t.Password = "твой пароль"
    t.InBuffer = "твой текст"
    t.Encrypt
    Debug.Print t.OutBuffer ' зашифрованное сообщение

    '**************расшифровка

t.Password = "твой пароль"
    t.InBuffer = "зашифрованное сообщение"
    t.Decrypt
     Debug.Print t.OutBuffer ' расшифрованное сообщение