how to Get Sha512 Fast by vb6 use api CryptCreateHash

[xiaoyao]

best way by:
UPDATE: I PUT SPEED TEST CODE

'Solved: help with sha512 key Implementation in VB6 | Experts Exchange
'https://www.experts-exchange.com/questions/29116296/help-with-sha512-key-Implementation-in-VB6.html
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
Private Declare Function CryptReleaseContext Lib "advapi32.dll" _
                            (ByVal hProv 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, _
                             ByRef phHash As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" _
                            (ByVal hHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" _
                            (ByVal hHash As Long, pbData As Any, ByVal cbData As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" _
                            (ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, ByRef pcbData As Long, _
                             ByVal dwFlags As Long) As Long

Private Const PROV_RSA_FULL   As Long = 1
Private Const PROV_RSA_AES    As Long = 24
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000

Private Const HP_HASHVAL      As Long = 2
Private Const HP_HASHSIZE     As Long = 4

Private Const ALG_TYPE_ANY    As Long = 0
Private Const ALG_CLASS_HASH  As Long = 32768

Private Const ALG_SID_MD2     As Long = 1
Private Const ALG_SID_MD4     As Long = 2
Private Const ALG_SID_MD5     As Long = 3
Private Const ALG_SID_SHA     As Long = 4
Private Const ALG_SID_SHA_256 As Long = 12
Private Const ALG_SID_SHA_384 As Long = 13
Private Const ALG_SID_SHA_512 As Long = 14

Private Const CALG_MD2        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2)
Private Const CALG_MD4        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4)
Private Const CALG_MD5        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5)
Private Const CALG_SHA        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA)
Private Const CALG_SHA_256    As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_256)
Private Const CALG_SHA_384    As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_384)
Private Const CALG_SHA_512    As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_512)
Private Declare Function timeBeginPeriod Lib "winmm.dll" _
  (ByVal uPeriod As Long) As Long
Private Declare Function timeEndPeriod Lib "winmm.dll" _
  (ByVal uPeriod As Long) As Long

Private Declare Function timeGetTime Lib "winmm.dll" () As Long '该声明得到系统开机到现在的时间(单位：毫秒)


Private Sub Form_Load()

timeBeginPeriod 1
 
End Sub
Private Sub Command1_Click()
SpeedTest
End Sub

Sub SpeedTest()
 
Dim strData As String
Dim StrArr() As String
Dim i As Long
 
Dim lenStr As Long
lenStr = 30
For i = 1 To lenStr
    strData = strData & Right(i, 1)
Next
 
Dim Startid As Long, MinV As Long, CountUb As Long
MinV = 10000
CountUb = 9999
ReDim StrArr(0 To CountUb)
Startid = lenStr - 3
For i = MinV To MinV + CountUb
    Mid(strData, Startid, 4) = Right(i, 4)
    StrArr(i - MinV) = strData
Next
strData = "test"
Dim s As String * 128
Dim T As Long
T = timeGetTime
For i = 0 To CountUb
s = CreateHash(StrConv(StrArr(i), vbFromUnicode), CALG_SHA_512)
 
Next
 
MsgBox "UsedTime=" & timeGetTime - T
End Sub



Sub Test1()
Dim strData As String
strData = "test"
Dim s As String
s = CreateHash(StrConv(strData, vbFromUnicode), CALG_SHA_512)
MsgBox s
 
End Sub

Get Sha512 Fast by vb6 can't use CryptBinaryToString API.
it's base64 code

Private Declare Function CryptBinaryToStringA Lib "crypt32.dll" (ByVal pbBinary As Long, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As Long, ByRef pcchString As Long) As Long

Private Declare Function CryptStringToBinaryA Lib "crypt32.dll" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByVal pdwSkip As Long, ByVal pdwFlags As Long) As Long
Private Const CRYPT_STRING_BASE64 = &H1
Private Const CRYPT_STRING_BASE64_ANY = &H6

 
Private Sub Form_Load()
InputBox "", "1073741825", Hex(1073741825)
  Dim a As String
  a = Base64Encode(StrConv("TestStr", vbFromUnicode))
  MsgBox a

  MsgBox Decode(a)
  MsgBox Base64Decode(a)

End Sub

 

Function Base64Decode(ByVal data As String) As String
  Dim s As Long
  Dim ret() As Byte
  Dim retlen As Long
  Dim b() As Byte
  s = Len(data)

  b = StrConv(data, vbFromUnicode)
  '因为VB默认是Unicode字符，所以要转换成Ansi
  Call CryptStringToBinaryA(VarPtr(b(0)), s, CRYPT_STRING_BASE64_ANY, StrPtr(ret), retlen, 0, 0)
  If retlen = 0 Then Base64Decode = "": Exit Function
  ReDim ret(retlen - 1)
  Call CryptStringToBinaryA(VarPtr(b(0)), s, CRYPT_STRING_BASE64_ANY, VarPtr(ret(0)), retlen, 0, 0)
  Base64Decode = StrConv(LeftB(ret, retlen), vbUnicode)
End Function
Function Base64Encode(data() As Byte) As String
  Dim s As Long
  Dim ret() As Byte
  Dim retlen As Long
  s = UBound(data) + 1

  Call CryptBinaryToStringA(VarPtr(data(0)), s, 1073741825, StrPtr(ret), retlen)
  If retlen = 0 Then Exit Function

  'MsgBox retlen
  ReDim ret(retlen - 1)
  Call CryptBinaryToStringA(VarPtr(data(0)), s, 1073741825, VarPtr(ret(0)), retlen)
  Base64Encode = StrConv(LeftB(ret, retlen), vbUnicode)
End Function

[wqweto]

You have everything to figure it out in the code you posted.

Which part is slow for you? Have you micro-benchmarked it already?

cheers,
</wqw>

[xiaoyao]

len(str)=30
i test 10000 counts,used time:3000ms (i5 8600k),If multithreading is used, the speed of 6-core CPU can be increased by 3-5 times

[jpbro]

10,000 tests of Len(str) = 30 takes 3000ms on your machine? Can you post your test code?

[xiaoyao]

10,000 tests of Len(str) = 30 takes 3000ms on your machine? Can you post your test code?

ok,i put test code at page first.
I hope you can try other methods to find the fastest way to calculate.
For example, will the speed of 64 bit exe be doubled?
VC++， VB.NET ,C#,virtual Freebasic，PYTHON
JS: (32BIT,64BIT),CHROME,quickjs,v8 js
YOU CAN TRY

[dilettante]

How fast does it need to be?

I'd use CNG instead of legacy crypto:

Option Explicit

Private Const WIN32_NULL As Long = 0&

Private Enum NTSTATUS
    STATUS_SUCCESS = &H0&
    STATUS_BUFFER_TOO_SMALL = &HC0000023
    STATUS_DATA_ERROR = &HC000003E
    STATUS_INVALID_BUFFER_SIZE = &HC0000206
    STATUS_INVALID_HANDLE = &HC0000008
    STATUS_INVALID_PARAMETER = &HC000000D
    STATUS_INVALID_SIGNATURE = &HC000A000
    STATUS_NOT_FOUND = &HC0000225
    STATUS_NOT_SUPPORTED = &HC00000BB
    STATUS_NO_MEMORY = &HC0000017
    'Other encountered system values:
    NTE_BAD_DATA = &H80090005
    'Class defined extended values:
    C_NO_DATA_TO_HASH = &HE0000001
End Enum

Private Declare Function BCryptCloseAlgorithmProvider Lib "bcrypt" ( _
    ByVal hAlgorithm As Long, _
    ByVal dwFlags As Long) As NTSTATUS

Private Declare Function BCryptCreateHash Lib "bcrypt" ( _
    ByVal hAlgorithm As Long, _
    ByRef hHash As Long, _
    ByRef bHashObject As Any, _
    ByVal cbHashObject As Long, _
    ByVal pbSecret As Long, _
    ByVal cbSecret As Long, _
    ByVal dwFlags As Long) As Long

Private Declare Function BCryptDestroyHash Lib "bcrypt" ( _
    ByVal hHash As Long) As Long

Private Declare Function BCryptFinishHash Lib "bcrypt" ( _
    ByVal hHash As Long, _
    ByRef bOutput As Any, _
    ByVal cbOutput As Long, _
    ByVal dwFlags As Long) As Long

'BCryptGetProperty strings (subset used here).
Private Const BCRYPT_OBJECT_LENGTH As String = "ObjectLength"
Private Const BCRYPT_HASH_LENGTH As String = "HashDigestLength"

Private Declare Function BCryptGetProperty Lib "bcrypt" ( _
    ByVal hObject As Long, _
    ByVal pszProperty As Long, _
    ByRef bOutput As Any, _
    ByVal cbOutput As Long, _
    ByRef cbResult As Long, _
    ByVal dwFlags As Long) As NTSTATUS

Private Declare Function BCryptHashData Lib "bcrypt" ( _
    ByVal hHash As Long, _
    ByRef bInput As Any, _
    ByVal cbInput As Long, _
    ByVal dwFlags As Long) As Long

Private Const MS_PRIMITIVE_PROVIDER As String = "Microsoft Primitive Provider"

'Algorithm identifiers (subset used here).
Private Const BCRYPT_SHA512_ALGORITHM As String = "SHA512"

Private Declare Function BCryptOpenAlgorithmProvider Lib "bcrypt" ( _
    ByRef hAlgorithm As Long, _
    ByVal pszAlgId As Long, _
    ByVal pszImplementation As Long, _
    ByVal dwFlags As Long) As NTSTATUS

Private Const CRYPT_STRING_BASE64 = 1

Private Declare Function CryptBinaryToString Lib "Crypt32" _
    Alias "CryptBinaryToStringW" ( _
    ByRef bBinary As Byte, _
    ByVal cbBinary As Long, _
    ByVal dwFlags As Long, _
    ByVal pszString As Long, _
    ByRef cchString As Long) As Long

Private Declare Function timeGetTime Lib "winmm" () As Long

Private Function HashAnsi(ByRef UnicodeText As String, ByRef Base64 As String) As NTSTATUS
    Dim hAlgorithm As Long
    Dim cbHashObject As Long
    Dim cbResult As Long
    Dim cbHashBlock As Long
    Dim HashObject() As Byte
    Dim hHash As Long
    Dim AnsiData() As Byte
    Dim Hashed() As Byte

    If Len(UnicodeText) < 1 Then
        HashAnsi = C_NO_DATA_TO_HASH
        Exit Function
    End If
    HashAnsi = BCryptOpenAlgorithmProvider(hAlgorithm, _
                                           StrPtr(BCRYPT_SHA512_ALGORITHM), _
                                           StrPtr(MS_PRIMITIVE_PROVIDER), _
                                           0)
    If HashAnsi <> STATUS_SUCCESS Then GoTo ExitAlg
    HashAnsi = BCryptGetProperty(hAlgorithm, _
                                 StrPtr(BCRYPT_OBJECT_LENGTH), _
                                 cbHashObject, _
                                 LenB(cbHashObject), _
                                 cbResult, _
                                 0)
    If HashAnsi <> STATUS_SUCCESS Then GoTo ExitAlg
    HashAnsi = BCryptGetProperty(hAlgorithm, _
                                 StrPtr(BCRYPT_HASH_LENGTH), _
                                 cbHashBlock, _
                                 LenB(cbHashBlock), _
                                 cbResult, _
                                 0)
    If HashAnsi <> STATUS_SUCCESS Then GoTo ExitAlg
    ReDim HashObject(cbHashObject - 1)
    HashAnsi = BCryptCreateHash(hAlgorithm, _
                                hHash, _
                                HashObject(0), _
                                cbHashObject, _
                                WIN32_NULL, _
                                0, _
                                0)
    If HashAnsi <> STATUS_SUCCESS Then GoTo ExitAlg
    AnsiData = StrConv(UnicodeText, vbFromUnicode)
    HashAnsi = BCryptHashData(hHash, _
                              AnsiData(0), _
                              UBound(AnsiData) + 1, _
                              0)
    If HashAnsi <> STATUS_SUCCESS Then GoTo ExitHash
    ReDim Hashed(cbHashBlock - 1)
    HashAnsi = BCryptFinishHash(hHash, _
                                Hashed(0), _
                                cbHashBlock, _
                                0)
    If HashAnsi <> STATUS_SUCCESS Then GoTo ExitHash
    CryptBinaryToString Hashed(0), _
                        cbHashBlock, _
                        CRYPT_STRING_BASE64, _
                        WIN32_NULL, _
                        cbResult
    Base64 = String(cbResult, 0)
    CryptBinaryToString Hashed(0), _
                        cbHashBlock, _
                        CRYPT_STRING_BASE64, _
                        StrPtr(Base64), _
                        cbResult
ExitHash:
    BCryptDestroyHash hHash
ExitAlg:
    BCryptCloseAlgorithmProvider hAlgorithm, 0
End Function

Private Sub Main()
    Const ITERATION_COUNT As Long = "10,000"
    Dim T0 As Long
    Dim I As Long
    Dim B64Hash As String

    T0 = timeGetTime()
    For I = 1 To ITERATION_COUNT
        HashAnsi "test56789012345678901234567890", B64Hash
    Next
    Dlg.Message "Test results", ITERATION_COUNT, timeGetTime() - T0, B64Hash
End Sub

Seems fast enough on this really old PC:

Minimum supported client: Windows Vista

[xiaoyao]

How fast does it need to be?
I'd use CNG instead of legacy crypto:

it's only base64,do you have sha512 api or other code function ?
you can try base64 without api,only use vb6 code,and test speed

[dilettante]

it's only base64

[xiaoyao]

SHA256 CODE:

Function HMACSHA256(strToSign As String, strKey() As Byte)
Dim lngLoop As Long
Dim oUTF, oEnc
Dim HMAC() As Byte
Dim lastrow As Long

On Error GoTo err_handler

Set oUTF = CreateObject("System.Text.UTF8Encoding")
Set oEnc = CreateObject("System.Security.Cryptography.HMACSHA256")
oEnc.Key = strKey
HMAC = oEnc.ComputeHash_2(oUTF.GetBytes_4(strToSign))

HMACSHA256 = HMAC

Exit Function

err_handler:
 
End Function

[wqweto]

Naming something strKey() As Byte is mind-boggling when you have strToSign As String in the very same code snippet.

Also note that this is *not* SHA256 CODE because it is computing a form of MAC (Message Authentication Code) the so called HMAC (Hash Message Authentication Code) which accepts as parameter a hash function in this particular case SHA-256 and a secret key (the unfortunately named strKey parameter).

My point being that HMAC-SHA256 as crypto primitive is very different than SHA-256 hash per se.

cheers,
</wqw>

[dilettante]

Exactly. I don't think the language barrier helps much either.

If you want the HMAC take a look at examples in the CodeBank.