Execlセル内でハッシュする

外部に提出しないExeclは効率UPのため2003を使用しています。最新のExeclでは、base64 エンコードくらいあるかと思っていましたがないんですね。win32APIを動的callできますが、Visual Studio 6 でインストールされる VB6用Declare 宣言をまとめた winapi32.txt に入ってない。手打ちは面倒なので検索すると、https://gist.github.com/rmdavy/db7cb6d81cc487172a86430f68633a21 に公開されていました。セル内使用に特化させ、コードが見にくい、エラー処理不足、32bit対応を直したので、ここで公開いたします。

#If Win64 Then
Private Declare PtrSafe Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" _
                            (ByRef phProv As LongPtr, ByVal pszContainer As String, ByVal pszProvider As String, _
                             ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32.dll" _
                            (ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptCreateHash Lib "advapi32.dll" _
                            (ByVal hProv As LongPtr, ByVal Algid As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, _
                             ByRef phHash As LongPtr) As Long
Private Declare PtrSafe Function CryptDestroyHash Lib "advapi32.dll" _
                            (ByVal hHash As LongPtr) As Long
Private Declare PtrSafe Function CryptHashData Lib "advapi32.dll" _
                            (ByVal hHash As LongPtr, pbData As Any, ByVal cbData As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32.dll" _
                            (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByRef pcbData As Long, _
                             ByVal dwFlags As Long) As Long
Else
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
#End If

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)

'======================= Create Hash =======================
Private Function CreateHash(abytData() As Byte, ByVal lngAlgID As Long) As String
    On Error GoTo ERROR01

    CreateHash = "Error"

#If Win64 Then
    Dim hProv As LongPtr
    Dim hHash As LongPtr
#Else
    Dim hProv As Long
    Dim hHash As Long
#End If
    Dim abytHash(0 To 63) As Byte
    Dim lngLength As Long
    Dim lngResult As Long
    Dim strHash As String
    Dim i As Long
    Dim z As Long
    strHash = ""
    
    z = 0
    If CryptAcquireContext(hProv, vbNullString, vbNullString, _
                           IIf(lngAlgID >= CALG_SHA_256, PROV_RSA_AES, PROV_RSA_FULL), _
                           CRYPT_VERIFYCONTEXT) = 0& Then
        CreateHash = "Error: CryptAcquireContext"
        Return
    End If
                           
    If CryptCreateHash(hProv, lngAlgID, 0&, 0&, hHash) = 0& Then
        CreateHash = "Error: CryptCreateHash"
        Return
    End If
        
    lngLength = UBound(abytData()) - LBound(abytData()) + 1
            
    lngResult = CryptHashData(hHash, abytData(LBound(abytData())), lngLength, 0&)
    If lngResult = 0& Then
        CreateHash = "Error: CryptHashData"
        Return
    End If
  
    lngLength = UBound(abytHash()) - LBound(abytHash()) + 1
        
    If CryptGetHashParam(hHash, HP_HASHVAL, abytHash(LBound(abytHash())), lngLength, z) = 0& Then
        CreateHash = "Error: CryptGetHashParam"
        Return
    End If
        
    For i = 0 To lngLength - 1
        strHash = strHash & Right$("0" & Hex$(abytHash(LBound(abytHash()) + i)), 2)
    Next i
  
    If CryptDestroyHash(hHash) = 0& Then
        CreateHash = "Error: CryptDestroyHash"
        Return
    End If
       
    If CryptReleaseContext(hProv, 0&) = 0& Then
        CreateHash = "Error: CryptReleaseContext"
        Return
    End If 
    
    CreateHash = LCase$(strHash)
    
    Exit Function
    
ERROR01:
    CreateHash = "Error: " & Err.Description
End Function

'=========== Create Hash From String(Shift_JIS)  ================
Private Function CreateHashString(ByVal strData As String, ByVal lngAlgID As Long) As String
    On Error GoTo ERROR01

    CreateHashString = "Error"
    
    If Len(strData) = 0 Then
        Return
    End If

    CreateHashString = CreateHash(StrConv(strData, vbFromUnicode), lngAlgID)
    Exit Function
    
ERROR01:
End Function

'======================= MD5 =======================
Public Function MD5Hash(ByVal strData As String) As String
    On Error GoTo ERROR01

    MD5Hash = "Error"
    MD5Hash = CreateHashString(strData, CALG_MD5)
    Exit Function
       
ERROR01:
End Function

'======================= SHA-1 ======================= 
Public Function SHA1Hash(ByVal strData As String) As String
    On Error GoTo ERROR01

    SHA1Hash = "Error"
    SHA1Hash = CreateHashString(strData, CALG_SHA)
    Exit Function
       
ERROR01:
End Function

'======================= SHA-256 =======================
Public Function SHA256Hash(ByVal strData As String) As String
    On Error GoTo ERROR01

    SHA256Hash = "Error"
    SHA256Hash = CreateHashString(strData, CALG_SHA_256)
    Exit Function
        
ERROR01:
End Function

'======================= SHA-384 =======================
Public Function SHA384Hash(ByVal strData As String) As String
    On Error GoTo ERROR01

    SHA384Hash = "Error"
    SHA384Hash = CreateHashString(strData, CALG_SHA_384)
    Exit Function
    
ERROR01:
End Function

'======================= SHA-512 =======================
Public Function SHA512Hash(ByVal strData As String) As String
    On Error GoTo ERROR01

    SHA512Hash = "Error"
    SHA512Hash = CreateHashString(strData, CALG_SHA_512)
    Exit Function
    
ERROR01:
End Function

しかし CryptAcquireContext 系は現在非奨励で、新しいのを使えとMicrosoft公開情報に掲載されています。いずれ調べたいと思います。