SHA512

'*******************************************************************************
' MODULE:            SHA-512
' AUTHOR:            David Svaiter
' CREATED:          28 July 2002
' COPYRIGHT:       Copyright 2002 Cypher (www.cypher.com.br)
'
'  This code calculates message digest (unique signatures for strings/values), using
'   the SHA algorithm on 512 bits of resolution (64 bytes for each result/digest).
'
'   We use it here at CYPHER to calculates secure values inside our crypto shareware tools and
'   custom software solutions.  Feel free to use it into your programs and remember to attach
'   the MATH.DLL library, since our modules use it to get faster binary calculations.  This MATH
'   is a CYPHER property (developed code under copyrights), but you can use and distribute it freely.
'
'   We do not distribute codes in our site, but if you want privacy in your computer environment,
'   we invite you to know our cryptographic applications at:     www.cypher.com.br
'
'
'   Enjoy It !
 
'*******************************************************************************
' This code is inpired in the Phil Fresle's code (SHA256)
' Web Site:  http://www.frez.co.uk
' E-mail:    sales@frez.co.uk
'*******************************************************************************
Option Explicit
 
 
 
 
Private Declare Function LSHL Lib "MATH.DLL" (ByRef valor As Long, ByRef ToLeft As Long) As Long
Private Declare Function LSHR Lib "MATH.DLL" (ByRef valor As Long, ByRef ToRight As Long) As Long
Private Declare Function LRL Lib "MATH.DLL" (ByRef valor As Long, ByRef ToLeft As Long) As Long
Private Declare Function LRR Lib "MATH.DLL" (ByRef valor As Long, ByRef ToRight As Long) As Long
Private Declare Function LRLb Lib "MATH.DLL" (ByRef valor As Long, ByRef ToLeft As Long) As Long
Private Declare Function LRRb Lib "MATH.DLL" (ByRef valor As Long, ByRef ToRight As Long) As Long
Private Declare Function ADDu Lib "MATH.DLL" (ByRef valor As Long, ByRef valor2 As Long) As Long
 
Private Declare Function GetInputState Lib "user32" () As Long
 
 
 
Private m_lOnBits(30)   As Long
Private m_l2Power(30)   As Long
Private K(160)           As Long
 
 
 
 
Private Const BITS_TO_A_BYTE  As Long = 8
Private Const BYTES_TO_A_WORD As Long = 4
Private Const BITS_TO_A_WORD  As Long = BYTES_TO_A_WORD * BITS_TO_A_BYTE
 
'*******************************************************************************
' Class_Initialize (SUB)
'*******************************************************************************
Private Sub Initialize()
 
    ' Could have done this with a loop calculating each value, but simply
    ' assigning the values is quicker - BITS SET FROM RIGHT
    
    m_lOnBits(0) = 1            ' 00000000000000000000000000000001
    m_lOnBits(1) = 3            ' 00000000000000000000000000000011
    m_lOnBits(2) = 7            ' 00000000000000000000000000000111
    m_lOnBits(3) = 15           ' 00000000000000000000000000001111
    m_lOnBits(4) = 31           ' 00000000000000000000000000011111
    m_lOnBits(5) = 63           ' 00000000000000000000000000111111
    m_lOnBits(6) = 127          ' 00000000000000000000000001111111
    m_lOnBits(7) = 255          ' 00000000000000000000000011111111
    m_lOnBits(8) = 511          ' 00000000000000000000000111111111
    m_lOnBits(9) = 1023         ' 00000000000000000000001111111111
    m_lOnBits(10) = 2047        ' 00000000000000000000011111111111
    m_lOnBits(11) = 4095        ' 00000000000000000000111111111111
    m_lOnBits(12) = 8191        ' 00000000000000000001111111111111
    m_lOnBits(13) = 16383       ' 00000000000000000011111111111111
    m_lOnBits(14) = 32767       ' 00000000000000000111111111111111
    m_lOnBits(15) = 65535       ' 00000000000000001111111111111111
    m_lOnBits(16) = 131071      ' 00000000000000011111111111111111
    m_lOnBits(17) = 262143      ' 00000000000000111111111111111111
    m_lOnBits(18) = 524287      ' 00000000000001111111111111111111
    m_lOnBits(19) = 1048575     ' 00000000000011111111111111111111
    m_lOnBits(20) = 2097151     ' 00000000000111111111111111111111
    m_lOnBits(21) = 4194303     ' 00000000001111111111111111111111
    m_lOnBits(22) = 8388607     ' 00000000011111111111111111111111
    m_lOnBits(23) = 16777215    ' 00000000111111111111111111111111
    m_lOnBits(24) = 33554431    ' 00000001111111111111111111111111
    m_lOnBits(25) = 67108863    ' 00000011111111111111111111111111
    m_lOnBits(26) = 134217727   ' 00000111111111111111111111111111
    m_lOnBits(27) = 268435455   ' 00001111111111111111111111111111
    m_lOnBits(28) = 536870911   ' 00011111111111111111111111111111
    m_lOnBits(29) = 1073741823  ' 00111111111111111111111111111111
    m_lOnBits(30) = 2147483647  ' 01111111111111111111111111111111
    
    ' Could have done this with a loop calculating each value, but simply
    ' assigning the values is quicker - POWERS OF 2
    m_l2Power(0) = 1            ' 00000000000000000000000000000001
    m_l2Power(1) = 2            ' 00000000000000000000000000000010
    m_l2Power(2) = 4            ' 00000000000000000000000000000100
    m_l2Power(3) = 8            ' 00000000000000000000000000001000
    m_l2Power(4) = 16           ' 00000000000000000000000000010000
    m_l2Power(5) = 32           ' 00000000000000000000000000100000
    m_l2Power(6) = 64           ' 00000000000000000000000001000000
    m_l2Power(7) = 128          ' 00000000000000000000000010000000
    m_l2Power(8) = 256          ' 00000000000000000000000100000000
    m_l2Power(9) = 512          ' 00000000000000000000001000000000
    m_l2Power(10) = 1024        ' 00000000000000000000010000000000
    m_l2Power(11) = 2048        ' 00000000000000000000100000000000
    m_l2Power(12) = 4096        ' 00000000000000000001000000000000
    m_l2Power(13) = 8192        ' 00000000000000000010000000000000
    m_l2Power(14) = 16384       ' 00000000000000000100000000000000
    m_l2Power(15) = 32768       ' 00000000000000001000000000000000
    m_l2Power(16) = 65536       ' 00000000000000010000000000000000
    m_l2Power(17) = 131072      ' 00000000000000100000000000000000
    m_l2Power(18) = 262144      ' 00000000000001000000000000000000
    m_l2Power(19) = 524288      ' 00000000000010000000000000000000
    m_l2Power(20) = 1048576     ' 00000000000100000000000000000000
    m_l2Power(21) = 2097152     ' 00000000001000000000000000000000
    m_l2Power(22) = 4194304     ' 00000000010000000000000000000000
    m_l2Power(23) = 8388608     ' 00000000100000000000000000000000
    m_l2Power(24) = 16777216    ' 00000001000000000000000000000000
    m_l2Power(25) = 33554432    ' 00000010000000000000000000000000
    m_l2Power(26) = 67108864    ' 00000100000000000000000000000000
    m_l2Power(27) = 134217728   ' 00001000000000000000000000000000
    m_l2Power(28) = 268435456   ' 00010000000000000000000000000000
    m_l2Power(29) = 536870912   ' 00100000000000000000000000000000
    m_l2Power(30) = 1073741824  ' 01000000000000000000000000000000
    
    ' Just put together the K array once
K(0) = &H428A2F98
K(1) = &HD728AE22
K(2) = &H71374491
K(3) = &H23EF65CD
K(4) = &HB5C0FBCF
K(5) = &HEC4D3B2F
K(6) = &HE9B5DBA5
K(7) = &H8189DBBC
K(8) = &H3956C25B
K(9) = &HF348B538
K(10) = &H59F111F1
K(11) = &HB605D019
K(12) = &H923F82A4
K(13) = &HAF194F9B
K(14) = &HAB1C5ED5
K(15) = &HDA6D8118
K(16) = &HD807AA98
K(17) = &HA3030242
K(18) = &H12835B01
K(19) = &H45706FBE
K(20) = &H243185BE
K(21) = &H4EE4B28C
K(22) = &H550C7DC3
K(23) = &HD5FFB4E2
K(24) = &H72BE5D74
K(25) = &HF27B896F
K(26) = &H80DEB1FE
K(27) = &H3B1696B1
K(28) = &H9BDC06A7
K(29) = &H25C71235
K(30) = &HC19BF174
K(31) = &HCF692694
K(32) = &HE49B69C1
K(33) = &H9EF14AD2
K(34) = &HEFBE4786
K(35) = &H384F25E3
K(36) = &HFC19DC6
K(37) = &H8B8CD5B5
K(38) = &H240CA1CC
K(39) = &H77AC9C65
K(40) = &H2DE92C6F
K(41) = &H592B0275
K(42) = &H4A7484AA
K(43) = &H6EA6E483
K(44) = &H5CB0A9DC
K(45) = &HBD41FBD4
K(46) = &H76F988DA
K(47) = &H831153B5
K(48) = &H983E5152
K(49) = &HEE66DFAB
K(50) = &HA831C66D
K(51) = &H2DB43210
K(52) = &HB00327C8
K(53) = &H98FB213F
K(54) = &HBF597FC7
K(55) = &HBEEF0EE4
K(56) = &HC6E00BF3
K(57) = &H3DA88FC2
K(58) = &HD5A79147
K(59) = &H930AA725
K(60) = &H6CA6351
K(61) = &HE003826F
K(62) = &H14292967
K(63) = &HA0E6E70
K(64) = &H27B70A85
K(65) = &H46D22FFC
K(66) = &H2E1B2138
K(67) = &H5C26C926
K(68) = &H4D2C6DFC
K(69) = &H5AC42AED
K(70) = &H53380D13
K(71) = &H9D95B3DF
K(72) = &H650A7354
K(73) = &H8BAF63DE
K(74) = &H766A0ABB
K(75) = &H3C77B2A8
K(76) = &H81C2C92E
K(77) = &H47EDAEE6
K(78) = &H92722C85
K(79) = &H1482353B
K(80) = &HA2BFE8A1
K(81) = &H4CF10364
K(82) = &HA81A664B
K(83) = &HBC423001
K(84) = &HC24B8B70
K(85) = &HD0F89791
K(86) = &HC76C51A3
K(87) = &H654BE30
K(88) = &HD192E819
K(89) = &HD6EF5218
K(90) = &HD6990624
K(91) = &H5565A910
K(92) = &HF40E3585
K(93) = &H5771202A
K(94) = &H106AA070
K(95) = &H32BBD1B8
K(96) = &H19A4C116
K(97) = &HB8D2D0C8
K(98) = &H1E376C08
K(99) = &H5141AB53
K(100) = &H2748774C
K(101) = &HDF8EEB99
K(102) = &H34B0BCB5
K(103) = &HE19B48A8
K(104) = &H391C0CB3
K(105) = &HC5C95A63
K(106) = &H4ED8AA4A
K(107) = &HE3418ACB
K(108) = &H5B9CCA4F
K(109) = &H7763E373
K(110) = &H682E6FF3
K(111) = &HD6B2B8A3
K(112) = &H748F82EE
K(113) = &H5DEFB2FC
K(114) = &H78A5636F
K(115) = &H43172F60
K(116) = &H84C87814
K(117) = &HA1F0AB72
K(118) = &H8CC70208
K(119) = &H1A6439EC
K(120) = &H90BEFFFA
K(121) = &H23631E28
K(122) = &HA4506CEB
K(123) = &HDE82BDE9
K(124) = &HBEF9A3F7
K(125) = &HB2C67915
K(126) = &HC67178F2
K(127) = &HE372532B
K(128) = &HCA273ECE
K(129) = &HEA26619C
K(130) = &HD186B8C7
K(131) = &H21C0C207
K(132) = &HEADA7DD6
K(133) = &HCDE0EB1E
K(134) = &HF57D4F7F
K(135) = &HEE6ED178
K(136) = &H6F067AA
K(137) = &H72176FBA
K(138) = &HA637DC5
K(139) = &HA2C898A6
K(140) = &H113F9804
K(141) = &HBEF90DAE
K(142) = &H1B710B35
K(143) = &H131C471B
K(144) = &H28DB77F5
K(145) = &H23047D84
K(146) = &H32CAAB7B
K(147) = &H40C72493
K(148) = &H3C9EBE0A
K(149) = &H15C9BEBC
K(150) = &H431D67C4
K(151) = &H9C100D4C
K(152) = &H4CC5D4BE
K(153) = &HCB3E42B6
K(154) = &H597F299C
K(155) = &HFC657E2A
K(156) = &H5FCB6FAB
K(157) = &H3AD6FAEC
K(158) = &H6C44198C
K(159) = &H4A475817
 
End Sub
 
 
'*******************************************************************************
' SHA512 (FUNCTION)
'
' PARAMETERS:
' (In/Out) -  String
'
' RETURN VALUE:
' String - The digest
'
' DESCRIPTION:
' Takes a string and uses the SHA-1024 digest to produce a signature for it.
'
'*******************************************************************************
Public Function SHA512(sMessage As String, Optional status As Boolean = False) As String
 
 
    Initialize
      
    Dim Hash(15) As Long
    
    Dim w(63)   As Long
    Dim a       As Long
    Dim b       As Long
    Dim c       As Long
    Dim d       As Long
    Dim e       As Long
    Dim F       As Long
    Dim g       As Long
    Dim h       As Long
    Dim i       As Long
    Dim j       As Long
    Dim t1      As Long
    Dim t2      As Long
    
    Dim M As Long
    Dim n As Long
    Dim o As Long
    Dim p As Long
    Dim q As Long
    Dim R As Long
    Dim S As Long
    Dim t As Long
    
    
    Dim lMessageLength  As Long
    Dim lNumberOfWords  As Long
    Dim lWordArray()    As Long
    Dim lBytePosition   As Long
    Dim lByteCount      As Long
    Dim lWordCount      As Long
    Dim lByte           As Long
    
    Const MODULUS_BITS      As Long = 512
    Const CONGRUENT_BITS    As Long = 448
    
    Dim NextPercent As Variant, AtualPercent As Variant
    
    
    
    
    
    ' Initial hash values
    
    
 Hash(0) = &H6A09E667
 Hash(1) = &H13BCC908
 Hash(2) = &HBB67AE85
 Hash(3) = &H84CAA73B
 Hash(4) = &H3C6EF372
 Hash(5) = &HFE94F82B
 Hash(6) = &HA54FF53A
 Hash(7) = &H5F1D36F1
Hash(8) = &H510E527F
Hash(9) = &HADE682D1
Hash(10) = &H9B05688C
Hash(11) = &H2B3E6C1F
Hash(12) = &H1F83D9AB
Hash(13) = &HFB41BD6B
Hash(14) = &H5BE0CD19
Hash(15) = &H137E2179
    
    lMessageLength = Len(sMessage)
    
    
    On Local Error Resume Next
    
    Dim total As Long, Passo As Long
    
    lNumberOfWords = (((lMessageLength + _
        ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ _
        (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * _
        (MODULUS_BITS \ BITS_TO_A_WORD)
    
    ReDim lWordArray(lNumberOfWords - 1)
    
    lBytePosition = 0
    lByteCount = 0
    
    
    Passo = 1
    total = lMessageLength
    
    
    
    
    
    Do Until lByteCount >= lMessageLength
        ' Each word is 4 bytes
        lWordCount = lByteCount \ BYTES_TO_A_WORD
        
        lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
        
        ' NOTE: This is where we are using just the first byte of each unicode
        ' character, you may want to make the change here, or to the SHA256 method
        ' so it accepts a byte array.
        
        lByte = AscB(Mid(sMessage, lByteCount + 1, 1))
        lWordArray(lWordCount) = lWordArray(lWordCount) Or LSHL(lByte, lBytePosition)
        lByteCount = lByteCount + 1
       
       
       If GetInputState() <> 0 Then DoEvents
    Loop
 
 
 
 
 
 
 
    lWordCount = lByteCount \ BYTES_TO_A_WORD
    lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
 
    lWordArray(lWordCount) = lWordArray(lWordCount) Or LSHL(&H80, lBytePosition)
    lWordArray(lNumberOfWords - 1) = LSHL(lMessageLength, 3)
    lWordArray(lNumberOfWords - 2) = LSHR(lMessageLength, 29)
    
    
    total = UBound(lWordArray)
    Passo = 1
    
    ' Main loop
    For i = 0 To total Step 16
        a = Hash(0)
        b = Hash(1)
        c = Hash(2)
        d = Hash(3)
        e = Hash(4)
        F = Hash(5)
        g = Hash(6)
        h = Hash(7)
        
        M = Hash(8)
        n = Hash(9)
        o = Hash(10)
        p = Hash(11)
        q = Hash(12)
        R = Hash(13)
        S = Hash(14)
        t = Hash(15)
        
        
        
        
        For j = 0 To 159
            If j < 16 Then
                w(j) = lWordArray(j + i)
            Else
                w(j) = ADDu(ADDu(ADDu((LRRb(w(j - 2), 17) Xor LRRb(w(j - 2), 19) Xor LSHR(w(j - 2), 10)), w(j - 7)), (LRRb(w(j - 15), 7) Xor LRRb(w(j - 15), 18) Xor LSHR(w(j - 15), 3))), w(j - 16))
            End If
                
            t1 = ADDu(ADDu(ADDu(ADDu(h, (LRRb(e, 6) Xor LRRb(e, 11) Xor LRRb(e, 25))), ((e And F) Xor ((Not e) And g))), K(j)), w(j))
            t2 = ADDu((LRRb(a, 2) Xor LRRb(a, 13) Xor LRRb(a, 22)), ((a And b) Xor (a And c) Xor (b And c)))
            
            t = ADDu(S, g)
            S = ADDu(R, F)
            R = ADDu(q, e)
            q = ADDu(p, d)
            p = ADDu(o, c)
            o = ADDu(n, b)
            n = ADDu(M, t2)
            M = ADDu(h, a)
            
            h = g
            g = F
            F = e
            e = ADDu(d, t1)
            d = c
            c = b
            b = a
            a = ADDu(t1, t2)
            
        Next
        
        Hash(0) = ADDu(a, Hash(0))
        Hash(1) = ADDu(b, Hash(1))
        Hash(2) = ADDu(c, Hash(2))
        Hash(3) = ADDu(d, Hash(3))
        Hash(4) = ADDu(e, Hash(4))
        Hash(5) = ADDu(F, Hash(5))
        Hash(6) = ADDu(g, Hash(6))
        Hash(7) = ADDu(h, Hash(7))
    
          
        Hash(8) = ADDu(M, Hash(8))
        Hash(9) = ADDu(n, Hash(9))
        Hash(10) = ADDu(o, Hash(10))
        Hash(11) = ADDu(p, Hash(11))
        Hash(12) = ADDu(q, Hash(12))
        Hash(13) = ADDu(R, Hash(13))
        Hash(14) = ADDu(S, Hash(14))
        Hash(15) = ADDu(t, Hash(15))
      
      
      If GetInputState() <> 0 Then
            DoEvents
      End If
    
    Next
    
    
    SHA512 = UCase(Right$("00000000" & Hex(Hash(0)), 8) & _
        Right("00000000" & Hex(Hash(1)), 8) & _
        Right("00000000" & Hex(Hash(2)), 8) & _
        Right("00000000" & Hex(Hash(3)), 8) & _
        Right("00000000" & Hex(Hash(4)), 8) & _
        Right("00000000" & Hex(Hash(5)), 8) & _
        Right("00000000" & Hex(Hash(6)), 8) & _
        Right("00000000" & Hex(Hash(7)), 8) & _
        Right("00000000" & Hex(Hash(8)), 8) & _
        Right("00000000" & Hex(Hash(9)), 8) & _
        Right("00000000" & Hex(Hash(10)), 8) & _
        Right("00000000" & Hex(Hash(11)), 8) & _
        Right("00000000" & Hex(Hash(12)), 8) & _
        Right("00000000" & Hex(Hash(13)), 8) & _
        Right("00000000" & Hex(Hash(14)), 8) & _
        Right("00000000" & Hex(Hash(15)), 8))
    
End Function

    On Local Error Resume Next

' Шифрование данных RSA с использованием cng
' VBOrion
 
Option Explicit
 
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As Long
    lpstrCustomFilter As Long
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As Long
    nMaxFile As Long
    lpstrFileTitle As Long
    nMaxFileTitle As Long
    lpstrInitialDir As Long
    lpstrTitle As Long
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type
 
Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
 
Private Const BIF_RETURNONLYFSDIRS = &H1&
Private Const MAX_PATH = 260
Private Const BCRYPT_RSA_ALGORITHM = "RSA"
Private Const BCRYPT_RSAPRIVATE_BLOB = "RSAPRIVATEBLOB"
Private Const BCRYPT_RSAPUBLIC_BLOB = "RSAPUBLICBLOB"
Private Const BCRYPT_BLOCK_LENGTH = "BlockLength"
Private Const BCRYPT_PAD_PKCS1 = 2
 
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListW" (ByVal pidl As Long, ByVal pszPath As Long) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderW" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameW" (ByRef pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameW" (ByRef pOpenfilename As OPENFILENAME) As Long
 
Private Declare Function BCryptOpenAlgorithmProvider Lib "Bcrypt" (ByRef phAlgorithm As Long, ByVal pszAlgId As Long, _
                                                            ByVal pszImplementation As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptCloseAlgorithmProvider Lib "Bcrypt" (ByVal hAlgorithm As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptGenerateKeyPair Lib "Bcrypt" (ByVal hAlgorithm As Long, ByRef phKey As Long, _
                                                            ByVal dwLength As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptDestroyKey Lib "Bcrypt" (ByVal hKey As Long) As Long
Private Declare Function BCryptFinalizeKeyPair Lib "Bcrypt" (ByVal hKey As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptExportKey Lib "Bcrypt" (ByVal hKey As Long, ByVal hExportKey As Long, _
                                                       ByVal pszBlobType As Long, ByRef pbOutput As Any, _
                                                       ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptImportKeyPair Lib "Bcrypt" (ByVal hAlgorithm As Long, ByVal hImportKey As Long, _
                                                       ByVal pszBlobType As Long, ByRef phKey As Long, _
                                                       ByRef pbInput As Any, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptEncrypt Lib "Bcrypt" (ByVal hKey As Long, ByRef pbInput As Any, _
                                                       ByVal cbInput As Long, ByRef pPaddingInfo As Any, _
                                                       ByRef pbIV As Any, ByVal cbIV As Long, ByRef pbOutput As Any, _
                                                       ByVal cbOutput As Long, ByRef pcbResult As Long, _
                                                       ByVal dwFlags As Long) As Long
Private Declare Function BCryptDecrypt Lib "Bcrypt" (ByVal hKey As Long, ByRef pbInput As Any, _
                                                       ByVal cbInput As Long, ByRef pPaddingInfo As Any, _
                                                       ByRef pbIV As Any, ByVal cbIV As Long, ByRef pbOutput As Any, _
                                                       ByVal cbOutput As Long, ByRef pcbResult As Long, _
                                                       ByVal dwFlags As Long) As Long
Private Declare Function BCryptGetProperty Lib "Bcrypt" (ByVal hObject As Long, ByVal pszProperty As Long, _
                                                            ByRef pbOutput As Any, ByVal cbOutput As Long, _
                                                            ByRef pcbResult As Long, ByVal dwFlags As Long) As Long
Private Declare Sub GetMem4 Lib "msvbvm60" (src As Any, Dst As Any)
 
' Номер ошибки
Private hr As Long
 
Private Sub cmdDecrypt_Click()
    Dim hProv As Long
    Dim hKey As Long
    Dim PrivateKey() As Byte
    Dim InData() As Byte
    Dim Size As Long
    Dim BlockSize As Long
    Dim PartSize As Long
    Dim SizeOfData As Long
    Dim OutData() As Byte
    Dim i As Long
    Dim i2 As Long
    
    If Not OpenArrayFromFile(txtDecryptKey.Text, PrivateKey) Then
        MsgBox "Невозможно открыть файл ключа 0x" & Hex(Err.Number)
        Exit Sub
    End If
    
    If Not OpenArrayFromFile(txtDecryptInFile.Text, InData) Then
        MsgBox "Невозможно открыть входной файл 0x" & Hex(Err.Number)
        Exit Sub
    End If
    
    If Not CheckStatus(BCryptOpenAlgorithmProvider(hProv, StrPtr(BCRYPT_RSA_ALGORITHM), 0, 0)) Then
        MsgBox "BCryptOpenAlgorithmProvider failed 0x" & Hex(hr)
        Exit Sub
    End If
    
    ' Импортируем ключ
    If Not CheckStatus(BCryptImportKeyPair(hProv, 0, StrPtr(BCRYPT_RSAPRIVATE_BLOB), hKey, _
                PrivateKey(0), UBound(PrivateKey) + 1, 0)) Then
        MsgBox "BCryptImportKeyPair failed 0x" & Hex(hr)
        GoTo CleanUp
    End If
    
    ' Извлекаем длину в байтах блока
    If Not CheckStatus(BCryptGetProperty(hKey, StrPtr(BCRYPT_BLOCK_LENGTH), BlockSize, 4, 0, 0)) Then
        MsgBox "BCryptGetProperty failed 0x" & Hex(hr)
        GoTo CleanUp
    End If
    
    ' PKCS #1: RSA Version 1.5
    ' The length of the data D shall not be more than k-11 octets, which is
    ' positive since the length k of the modulus is at least 12 octets.
    ' Размер дешифруемого блока на 11 байт меньше. Неиспользуемые байты заполнениы случайными значениями
    PartSize = BlockSize - 11
    
    ' Извлекаем размер который хранится в первых 4-х байтах
    GetMem4 InData(0), SizeOfData
    
    ReDim OutData(SizeOfData - 1)
    
    i2 = 4
    
    Do While i < UBound(OutData)
        
        If i + PartSize > UBound(OutData) + 1 Then
            Size = UBound(OutData) - i + 1
        Else
            Size = PartSize
        End If
        
        ' Дешифруем по частям
        If Not CheckStatus(BCryptDecrypt(hKey, InData(i2), BlockSize, ByVal 0&, ByVal 0&, _
                0, OutData(i), Size, 0, BCRYPT_PAD_PKCS1)) Then
            MsgBox "BCryptDecrypt failed 0x" & Hex(hr)
            GoTo CleanUp
        End If
        
        i = i + PartSize
        i2 = i2 + BlockSize
        
    Loop
    
    If Not SaveArrayToFile(OutData, txtDecryptOutFile.Text) Then
        MsgBox "SaveArrayToFile failed 0x" & Hex(Err.Number)
        GoTo CleanUp
    End If
    
    MsgBox "Успешно!", vbInformation
    
CleanUp:
    
    If hKey Then
        BCryptDestroyKey hKey
    End If
    
    If hProv Then
        BCryptCloseAlgorithmProvider hProv, 0
    End If
    
End Sub
 
Private Sub cmdEncrypt_Click()
    Dim hProv As Long
    Dim hKey As Long
    Dim PublicKey() As Byte
    Dim InData() As Byte
    Dim BlockSize As Long
    Dim PartSize As Long
    Dim Size As Long
    Dim OutData() As Byte
    Dim i As Long
    Dim i2 As Long
    
    If Not OpenArrayFromFile(txtEncryptKey.Text, PublicKey) Then
        MsgBox "Невозможно открыть файл ключа 0x" & Hex(Err.Number)
        Exit Sub
    End If
    
    If Not OpenArrayFromFile(txtEncryptInFile.Text, InData) Then
        MsgBox "Невозможно открыть входной файл 0x" & Hex(Err.Number)
        Exit Sub
    End If
    
    If Not CheckStatus(BCryptOpenAlgorithmProvider(hProv, StrPtr(BCRYPT_RSA_ALGORITHM), 0, 0)) Then
        MsgBox "BCryptOpenAlgorithmProvider failed 0x" & Hex(hr)
        Exit Sub
    End If
    
    ' Импортируем ключ
    If Not CheckStatus(BCryptImportKeyPair(hProv, 0, StrPtr(BCRYPT_RSAPUBLIC_BLOB), hKey, _
                PublicKey(0), UBound(PublicKey) + 1, 0)) Then
        MsgBox "BCryptImportKeyPair failed 0x" & Hex(hr)
        GoTo CleanUp
    End If
    
    ' Извлекаем длину в байтах блока
    If Not CheckStatus(BCryptGetProperty(hKey, StrPtr(BCRYPT_BLOCK_LENGTH), BlockSize, 4, 0, 0)) Then
        MsgBox "BCryptGetProperty failed 0x" & Hex(hr)
        GoTo CleanUp
    End If
    
    ' PKCS #1: RSA Version 1.5
    ' The length of the data D shall not be more than k-11 octets, which is
    ' positive since the length k of the modulus is at least 12 octets.
    ' Размер дешифруемого блока на 11 байт меньше. Неиспользуемые байты заполнениы случайными значениями
    
    PartSize = BlockSize - 11
 
    ReDim OutData(-Int(-(UBound(InData) + 1) / PartSize) * BlockSize - 1 + 4)
    
    ' Сохраняем размер в первых 4-х байтах
    GetMem4 CLng(UBound(InData) + 1), OutData(0)
    
    i2 = 4
    
    Do While i < UBound(InData)
 
        If i + PartSize > UBound(InData) + 1 Then
            Size = UBound(InData) - i + 1
        Else
            Size = PartSize
        End If
        
        ' Шифруем по частям
        If Not CheckStatus(BCryptEncrypt(hKey, InData(i), Size, ByVal 0&, ByVal 0&, _
                0, OutData(i2), BlockSize, 0, BCRYPT_PAD_PKCS1)) Then
            MsgBox "BCryptEncrypt failed 0x" & Hex(hr)
            GoTo CleanUp
        End If
        
        i = i + PartSize
        i2 = i2 + BlockSize
        
    Loop
    
    If Not SaveArrayToFile(OutData, txtEncryptOutFile.Text) Then
        MsgBox "SaveArrayToFile failed 0x" & Hex(Err.Number)
        GoTo CleanUp
    End If
    
    MsgBox "Успешно!", vbInformation
    
CleanUp:
    
    If hKey Then
        BCryptDestroyKey hKey
    End If
    
    If hProv Then
        BCryptCloseAlgorithmProvider hProv, 0
    End If
    
End Sub
 
Private Sub cmdGenerateKeyPair_Click()
    Dim hProv As Long
    Dim hKey As Long
    Dim KeySize As Long
    Dim PrivateKey() As Byte
    Dim PublicKey() As Byte
    
    If Not CheckStatus(BCryptOpenAlgorithmProvider(hProv, StrPtr(BCRYPT_RSA_ALGORITHM), 0, 0)) Then
        MsgBox "BCryptOpenAlgorithmProvider failed 0x" & Hex(hr)
        Exit Sub
    End If
    
    If Not CheckStatus(BCryptGenerateKeyPair(hProv, hKey, 512, 0)) Then
        MsgBox "BCryptGenerateKeyPair failed 0x" & Hex(hr)
        GoTo CleanUp
    End If
    
    If Not CheckStatus(BCryptFinalizeKeyPair(hKey, 0)) Then
        MsgBox "BCryptFinalizeKeyPair failed 0x" & Hex(hr)
        GoTo CleanUp
    End If
    
    If Not CheckStatus(BCryptExportKey(hKey, 0, StrPtr(BCRYPT_RSAPRIVATE_BLOB), ByVal 0&, 0, KeySize, 0)) Then
        MsgBox "BCryptExportKey failed 0x" & Hex(hr)
        GoTo CleanUp
    End If
    
    ReDim PrivateKey(KeySize - 1)
    
    ' Приватный ключ содержит в себе также публичный
    If Not CheckStatus(BCryptExportKey(hKey, 0, StrPtr(BCRYPT_RSAPRIVATE_BLOB), PrivateKey(0), KeySize, KeySize, 0)) Then
        MsgBox "BCryptExportKey failed 0x" & Hex(hr)
        GoTo CleanUp
    End If
    
    If Not CheckStatus(BCryptExportKey(hKey, 0, StrPtr(BCRYPT_RSAPUBLIC_BLOB), ByVal 0&, 0, KeySize, 0)) Then
        MsgBox "BCryptExportKey failed 0x" & Hex(hr)
        GoTo CleanUp
    End If
    
    ReDim PublicKey(KeySize - 1)
    
    If Not CheckStatus(BCryptExportKey(hKey, 0, StrPtr(BCRYPT_RSAPUBLIC_BLOB), PublicKey(0), KeySize, KeySize, 0)) Then
        MsgBox "BCryptExportKey failed 0x" & Hex(hr)
        GoTo CleanUp
    End If
 
    If Not SaveArrayToFile(PrivateKey, txtPairPath.Text & "\private.bin") Then
        MsgBox "SaveArrayToFile failed 0x" & Hex(Err.Number)
        GoTo CleanUp
    End If
    
    If Not SaveArrayToFile(PublicKey, txtPairPath.Text & "\public.bin") Then
        MsgBox "SaveArrayToFile failed 0x" & Hex(Err.Number)
        GoTo CleanUp
    End If
    
    MsgBox "Успешно!", vbInformation
    
CleanUp:
    
    If hKey Then
        BCryptDestroyKey hKey
    End If
    
    If hProv Then
        BCryptCloseAlgorithmProvider hProv, 0
    End If
    
End Sub
 
Private Function CheckStatus(ByVal Value As Long) As Boolean
    hr = Value
    CheckStatus = Value >= 0
End Function
 
Private Sub cmdPickDecryptKey_Click()
    Dim Path As String
    
    Path = GetOpenFile("Закрытый ключ", "Все файлы" & vbNullChar & "*.*" & vbNullChar, Me.hWnd)
    If Len(Path) = 0 Then Exit Sub
    
    txtDecryptKey.Text = Path
    
End Sub
 
Private Sub cmdPickDecryptInFile_Click()
    Dim Path As String
    
    Path = GetOpenFile("Входной файл", "Все файлы" & vbNullChar & "*.*" & vbNullChar, Me.hWnd)
    If Len(Path) = 0 Then Exit Sub
    
    txtDecryptInFile.Text = Path
    
End Sub
 
Private Sub cmdPickDecryptOutFile_Click()
    Dim Path As String
    
    Path = GetSaveFile("Выходной файл", "Все файлы" & vbNullChar & "*.*" & vbNullChar, Me.hWnd)
    If Len(Path) = 0 Then Exit Sub
    
    txtDecryptOutFile.Text = Path
    
End Sub
 
Private Sub cmdPickEncryptInFile_Click()
    Dim Path As String
    
    Path = GetOpenFile("Входной файл", "Все файлы" & vbNullChar & "*.*" & vbNullChar, Me.hWnd)
    If Len(Path) = 0 Then Exit Sub
    
    txtEncryptInFile.Text = Path
    
End Sub
 
Private Sub cmdPickEncryptKey_Click()
    Dim Path As String
    
    Path = GetOpenFile("Открытый ключ", "Все файлы" & vbNullChar & "*.*" & vbNullChar, Me.hWnd)
    If Len(Path) = 0 Then Exit Sub
    
    txtEncryptKey.Text = Path
    
End Sub
 
Private Sub cmdPickEncryptOutFile_Click()
    Dim Path As String
    
    Path = GetSaveFile("Выходной файл", "Все файлы" & vbNullChar & "*.*" & vbNullChar, Me.hWnd)
    If Len(Path) = 0 Then Exit Sub
    
    txtEncryptOutFile.Text = Path
    
End Sub
 
Private Sub cmdPickPairPath_Click()
    Dim Path As String
    
    Path = GetOpenFolder("Выберите папку назначения", Me.hWnd)
    If Len(Path) = 0 Then Exit Sub
    
    txtPairPath.Text = Path
    
End Sub
 
Private Sub Form_Load()
    UpdateTab
End Sub
 
Private Sub UpdateTab()
    Dim pic As PictureBox
    Dim index As Long
    
    For Each pic In picContainer
        If pic.index = tabMain.SelectedItem.index - 1 Then
            pic.Visible = True
            pic.Move tabMain.ClientLeft, tabMain.ClientTop, tabMain.ClientWidth, tabMain.ClientHeight
        Else
            pic.Visible = False
        End If
    Next
    
End Sub
 
Private Sub tabMain_Click()
    UpdateTab
End Sub
 
Private Function SaveArrayToFile(ByRef Arr() As Byte, ByRef FileName As String) As Boolean
    Dim FileNumber As Integer
    
    On Error GoTo io_error
    
    FileNumber = FreeFile
    
    If Len(Dir$(FileName)) Then
        Kill FileName
    End If
    
    Open FileName For Binary As FileNumber
    
    Put FileNumber, , Arr
    
    SaveArrayToFile = True
    
io_error:
 
    Close FileNumber
        
End Function
 
Private Function OpenArrayFromFile(ByRef FileName As String, ByRef Arr() As Byte) As Boolean
    Dim FileNumber As Integer
    Dim Size As Long
    
    On Error GoTo io_error
    
    FileNumber = FreeFile
 
    Open FileName For Binary As FileNumber
    
    Size = LOF(FileNumber)
    
    If Size > 0 Then
        
        ReDim Arr(Size - 1)
        Get FileNumber, , Arr
    
    Else: Erase Arr()
    End If
    
    OpenArrayFromFile = True
    
io_error:
 
    Close FileNumber
        
End Function
 
Private Function GetOpenFile(ByRef title As String, ByRef filter As String, _
                 Optional ByVal hwndOwner As Long) As String
    Dim ofn As OPENFILENAME
    Dim out As String
    Dim i As Long
    
    ofn.nMaxFile = MAX_PATH
    out = String$(MAX_PATH, vbNullChar)
 
    ofn.hwndOwner = hwndOwner
    ofn.lpstrTitle = StrPtr(title)
    ofn.lpstrFile = StrPtr(out)
    ofn.lStructSize = Len(ofn)
    ofn.lpstrFilter = StrPtr(filter)
    
    If GetOpenFileName(ofn) Then
    
        i = InStr(1, out, vbNullChar, vbBinaryCompare)
        If i Then GetOpenFile = Left$(out, i - 1)
        
    End If
    
End Function
 
Private Function GetSaveFile(ByRef title As String, ByRef filter As String, _
                 Optional ByVal hwndOwner As Long) As String
    Dim ofn As OPENFILENAME
    Dim out As String
    Dim i As Long
    
    ofn.nMaxFile = MAX_PATH
    out = String$(MAX_PATH, vbNullChar)
 
    ofn.hwndOwner = hwndOwner
    ofn.lpstrTitle = StrPtr(title)
    ofn.lpstrFile = StrPtr(out)
    ofn.lStructSize = Len(ofn)
    ofn.lpstrFilter = StrPtr(filter)
    
    If GetSaveFileName(ofn) Then
    
        i = InStr(1, out, vbNullChar, vbBinaryCompare)
        If i Then GetSaveFile = Left$(out, i - 1)
        
    End If
    
End Function
 
Private Function GetOpenFolder(ByRef title As String, Optional ByVal hwndOwnder As Long) As String
    Dim bi As BROWSEINFO
    Dim pidl As Long
    Dim Path As String
    Dim res As Long
    
    bi.hOwner = Me.hWnd
    bi.pidlRoot = 0&
    bi.lpszTitle = StrPtr(title)
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    
    pidl = SHBrowseForFolder(bi)
    If pidl = 0 Then Exit Function
    
    Path$ = Space$(MAX_PATH)
    res = SHGetPathFromIDList(ByVal pidl, StrPtr(Path))
    
    If res Then
        GetOpenFolder = Mid$(Path, 1, InStr(1, Path, vbNullChar))
    End If
    
    CoTaskMemFree pidl
    
End Function