MOTO+4 Applocations のブログ

外部に提出しない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公開情報に掲載されています。いずれ調べたいと思います。

外部に提出しないExeclは効率UPのため2003を使用しています。最新のExeclでは、base64 エンコードくらいあるかと思っていましたが、ないんですね。「Execl base64」で検索してもあまり出てこなかったので、マクロExecl .xlm で作成しました。

Win32 APIの暗号化ライブラリで、API:CryptBinaryToStringA があったのでそちらの .dll を動的参照います。使用します。1コールでいけます。コードは以下の通りです。2003や32bit版offsice ビルドスイッチで切り分けています。URLセーフ(URLで使えない記号を置き替え、%xxのURLエンコードとはだいぶちがう) は、APIないので作りました。VBAエディタで「標準モジュール」に挿入します。

#If Win64 Then
Private Declare PtrSafe Function CryptBinaryToStringA Lib "Crypt32.dll" _
                            (pbBinary As Byte, _
                             ByVal cbBinary As Long, _
                             ByVal dwFlags As Long, _
                             pszString As Byte, _
                             pcchString As Long) As Long
#Else
Private Declare Function CryptBinaryToStringA Lib "Crypt32.dll" _
                            (pbBinary As Byte, _
                             ByVal cbBinary As Long, _
                             ByVal dwFlags As Long, _
                             pszString As Byte, _
                             pcchString As Long) As Long
#End If


Private Const CRYPT_STRING_BASE64HEADER As Long = &H0 ' Base64。証明書の先頭と末尾のヘッダーが含まれます。
Private Const CRYPT_STRING_BASE64 As Long = &H1 ' ヘッダーなしの Base64。
Private Const CRYPT_STRING_BINARY As Long = &H2 ' 純粋なバイナリ コピー。
Private Const CRYPT_STRING_BASE64REQUESTHEADER As Long = &H3 '要求の開始ヘッダーと終了ヘッダーを含む Base64。
Private Const CRYPT_STRING_HEX As Long = &H4 ' 16 進数のみ。
Private Const CRYPT_STRING_HEXASCII As Long = &H5 ' ASCII 文字表示の 16 進数。
Private Const CRYPT_STRING_BASE64X509CRLHEADER As Long = &H9 ' Base64( X.509 CRL の先頭ヘッダーと終了ヘッダーを含む)。
Private Const CRYPT_STRING_HEXADDR As Long = &HA 'アドレス表示を含む 16 進数。
Private Const CRYPT_STRING_HEXASCIIADDR As Long = &HB 'ASCII 文字とアドレス表示を含む 16 進数。
Private Const CRYPT_STRING_HEXRAW As Long = &HC ' 生の 16 進文字列。
Private Const CRYPT_STRING_STRICT = &H20000000 ' ASN.1 テキスト形式の厳密なデコードを適用します。

' BASE64
Public Function BASE64(ByVal hexData As String) As String
    On Error GoTo ERROR01

    BASE64 = "Error"
    
    ' String HEX をByte配列に変換
    Dim binIn(512) As Byte
    Dim binOut(512) As Byte
    Dim result As Long
    Dim sizeIn As Long
    Dim sizeIo As Long
   
    sizeIn = 0
    Dim i As Long

    If Len(hexData) = 0 Then
        Return
    End If
    
     If Len(hexData) Mod 2 <> 0 Then
        Return
    End If
    
    If Len(hexData) / 2 > UBound(binIn) - 1 Then
        Return
    End If
    
    For i = 1 To Len(hexData) Step 2
        binIn(sizeIn) = CLng("&h" & Mid(hexData, i, 2)) '16進バイナリ値に
        sizeIn = sizeIn + 1
    Next i
    
    sizeIo = UBound(binIn) - 1
    
    ' BASE64に変換
    result = CryptBinaryToStringA(binIn(0), sizeIn, CRYPT_STRING_BASE64, binOut(0), sizeIo)
    If result = 0 Then Return

    Dim base64str As String
    base64str = ""
    
    For i = 0 To sizeIo - 1
        base64str = base64str & Chr(binOut(i)) 'ASII値を文字に
    Next i
    
    BASE64 = base64str
    Exit Function
    
ERROR01:
End Function

' URL Safe BASE64
Public Function BASE64URLSAFE(ByVal hexData As String) As String
    On Error GoTo ERROR01

    BASE64URLSAFE = "Error"

    Dim base64str As String
    
    base64str = BASE64(hexData)
    If base64str = "Error" Then Exit Function
    
    ' URLエンコードと違い文字置換のみ
    ' Win32APIは無い。
    base64str = Replace(base64str, "=", "")
    base64str = Replace(base64str, "+", "-")
    base64str = Replace(base64str, "/", "_")
    
    BASE64URLSAFE = base64str
    Exit Function

ERROR01:
End Function

ちゃんとAPIエラー、引数エラー、VBエラー検出も組込みましょう。ネット上のサンプルはそれがあまりできていないようで実用上問題です。Execlの記述は、