ScrapCode/VB6/AdvApi32

Option Explicit

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 Declare Function CryptDeriveKey Lib "advapi32.dll" _
'    (ByVal hProv As Long, ByVal Algid As Long, ByVal hBaseData As Long, ByVal dwFlags As Long, _
'     ByRef phKey As Long) As Long
'Private Declare Function CryptDestroyKey Lib "advapi32.dll" _
'    (ByVal hHash As Long) As Long
'Private Declare Function CryptEncrypt Lib "advapi32.dll" _
'Private Declare Function CryptDecrypt Lib "advapi32.dll" _

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

Private Const HP_HASHVAL        As Long = 2

' Algorithm classes/types
Private Const ALG_CLASS_HASH    As Long = 32768
Private Const ALG_TYPE_ANY      As Long = 0

' Hash sub ids
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

' algorithm identifier definitions
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)

' SHA2-512 ハッシュ値計算
' ARG: 計算するデータのバイト配列
' RET: 計算されたハッシュ値のバイト配列
Public Function HashSHA512(abytData() As Byte) As Byte()
    Dim hProv As Long, hHash As Long
    Dim abytHash() As Byte
    Dim lngLength As Long
    
    If UBound(abytData()) - LBound(abytData()) < 0 Then
        GoTo ExitFunction
    End If
    
    If CryptAcquireContext(hProv, vbNullString, vbNullString, PROV_RSA_AES, CRYPT_VERIFYCONTEXT) = 0& Then
        GoTo ExitFunction
    End If
    
    If CryptCreateHash(hProv, CALG_SHA_512, 0&, 0&, hHash) = 0& Then
        GoTo CryptReleaseContext
    End If
    
    lngLength = UBound(abytData()) - LBound(abytData()) + 1
    If CryptHashData(hHash, abytData(LBound(abytData())), lngLength, 0&) = 0& Then
        GoTo CryptDestroyHash
    End If
    
    ReDim abytHash(63)
    lngLength = UBound(abytHash()) - LBound(abytHash()) + 1
    If CryptGetHashParam(hHash, HP_HASHVAL, abytHash(LBound(abytHash())), lngLength, 0&) <> 0& Then
        ReDim Preserve abytHash(lngLength - 1)
        HashSHA512 = abytHash
    End If

CryptDestroyHash:
    CryptDestroyHash hHash

CryptReleaseContext:
    CryptReleaseContext hProv, 0&

ExitFunction:

End Function

'Public Function CryptAES(abytData() As Byte, abytKey() As Byte) As Byte()
'End Function