vbaでhmac その2

前に書いたけど、今回は一発で行けます。

'http://msdn.microsoft.com/en-us/library/aa382379(v=vs.85).aspx 参考

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, ByRef pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" _
  (ByVal hHash As Long, ByVal dwParam As Long, ByRef pbData As Any, ByRef pdwDataLen As Long, ByVal dwFlags As Integer) 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 hKey As Long) As Long
Private Declare Function CryptSetHashParam Lib "advapi32.dll" _
  (ByVal hHash As Long, ByVal dwParam As Long, ByRef pbData As Any, ByVal dwFlags As Integer) As Long
Private Declare Function CryptImportKey Lib "advapi32.dll" _
  (ByVal hProv As Long, ByRef pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As Long, ByVal dwFlags As Long, ByRef phKey As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
  (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" _
  (Destination As Any, ByVal Length As Long)
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
Private Const MS_DEF_PROV As String = "Microsoft Base Cryptographic Provider v1.0"
Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_CLASS_HASH As Long = 32768
Private Const ALG_TYPE_BLOCK As Long = 1536
Private Const ALG_SID_SHA As Long = 4
Private Const ALG_SID_SHA1 As Long = ALG_SID_SHA
Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
Private Const ALG_TYPE_STREAM As Long = 2048
Private Const ALG_SID_RC4 As Long = 1
Private Const ALG_SID_RC2 As Long = 2
Private Const ALG_SID_HMAC As Long = 9
Private Const CALG_SHA As Long = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA
Private Const CALG_SHA1 As Long = CALG_SHA
Private Const CALG_RC2 As Long = ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_RC2
Private Const CALG_RC4 As Long = ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM Or ALG_SID_RC4
Private Const CALG_HMAC As Long = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_HMAC
Private Const HP_HMAC_INFO = &H5
Private Const HP_HASHVAL As Long = 2
Private Const PROV_RSA_FULL As Long = 1
Private Const PLAINTEXTKEYBLOB As Long = 8
Private Const CUR_BLOB_VERSION As Long = 2
Private Const CRYPT_IPSEC_HMAC_KEY = &H100
Private Type HMAC_Info
  HashAlgid As Long
  pbInnerString As Byte
  cbInnerString As Long
  pbOuterString As Byte
  cbOuterString As Long
End Type
Private Type BLOBHEADER
  bType As Byte
  bVersion As Byte
  reserved As Integer
  aiKeyAlg As Long
End Type
Private Type key_blob
  hdr As BLOBHEADER
  len As Long
  key(1024) As Byte '// TODO might want to dynamically allocate this, Should Be Fine though
End Type

Private Function hmac(ByVal strKey As String, ByVal strData As String) As String
  Dim bytKey() As Byte
  Dim bytData() As Byte
  Dim ret As Long
  Dim lngProv As Long       'コンテナオブジェクト
  Dim lngHash As Long       'ハッシュオブジェクト
  Dim lngHmacHash As Long   'ハッシュオブジェクト
  Dim lngHashSize As Long   'ハッシュサイズ
  Dim lngKey As Long        'キーオブジェクト
  Dim bytBuff() As Byte     'ハッシュが格納されるエリア
  Dim strHex As String      '16進数文字列
  Dim i As Long
  Dim HmacInfo As HMAC_Info
  Dim keyblob As key_blob
  Dim key_len As Long
  
  hmac = ""
  strHex = ""
  
  'バイト配列へ
  bytKey = StrConv(strKey, vbFromUnicode)
  bytData = StrConv(strData, vbFromUnicode)

  '1024バイトチェック
  key_len = UBound(bytKey) + 1
  If key_len > 1024 Then
    hmac = ""
    Exit Function
  End If

  'キーコンテナの作成
  ret = CryptAcquireContext(lngProv, vbNullString, vbNullString, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT)
  If ret = False Then
    GoTo ExitHandler
  End If

'  '鍵作り
'  ret = CryptDeriveKey(lngProv, CALG_RC2, lngHash, 0, lngKey)
'  If ret = False Then
'    Call CryptDestroyKey(lngKey)
'    GoTo ExitHandler
'  End If

  '// key creation based on
  '// http://mirror.leaseweb.com/NetBSD/NetBSD-release-5-0/src/dist/wpa/src/crypto/crypto_cryptoapi.c
  keyblob.hdr.bType = PLAINTEXTKEYBLOB
  keyblob.hdr.bVersion = CUR_BLOB_VERSION
  keyblob.hdr.reserved = 0
  '/*
  '* Note: RC2 is not really used, but that can be used to
  '* import HMAC keys of up to 16 byte long.
  '* CRYPT_IPSEC_HMAC_KEY flag for CryptImportKey() is needed to
  '* be able to import longer keys (HMAC-SHA1 uses 20-byte key).
  '*/
  keyblob.hdr.aiKeyAlg = CALG_RC2
  keyblob.len = key_len
  Call ZeroMemory(keyblob.key(0), key_len)
  Call CopyMemory(keyblob.key(0), bytKey(0), key_len)
  ret = CryptImportKey(lngProv, keyblob, 12 + key_len, 0, CRYPT_IPSEC_HMAC_KEY, lngKey)
  If ret = False Then
    GoTo ExitHandler
  End If
  
  'ハッシュオブジェクトの作成
  ret = CryptCreateHash(lngProv, CALG_HMAC, lngKey, 0, lngHmacHash)
  If ret = False Then
    GoTo ExitHandler
  End If
  
  'パラメータセット
  HmacInfo.HashAlgid = CALG_SHA1
  ret = CryptSetHashParam(lngHmacHash, HP_HMAC_INFO, HmacInfo, 0)
  If ret = False Then
    GoTo ExitHandler
  End If

  'ハッシュデータを作る
  ret = CryptHashData(lngHmacHash, bytData(0), UBound(bytData) + 1, 0)
  If ret = False Then
    GoTo ExitHandler
  End If

  '必要なサイズを取得
  ret = CryptGetHashParam(lngHmacHash, HP_HASHVAL, ByVal 0, lngHashSize, 0)
  If ret = False Then
    GoTo ExitHandler
  End If
  
  'ハッシュを取り出す
  ReDim bytBuff(lngHashSize - 1)
  For i = 0 To UBound(bytBuff)
    bytBuff(i) = 0
  Next
  ret = CryptGetHashParam(lngHmacHash, HP_HASHVAL, bytBuff(0), lngHashSize, 0)
  If ret = False Then
    GoTo ExitHandler
  End If

  'HEX文字列へ
  For i = 0 To UBound(bytBuff)
    strHex = strHex & Right("0" & LCase(Hex(bytBuff(i))), 2)
  Next
  
ExitHandler:
  If (lngHmacHash) Then
    CryptDestroyHash (lngHmacHash)
  End If
  If (lngKey) Then
    Call CryptDestroyKey(lngKey)
  End If
  If (lngHash) Then
    Call CryptDestroyHash(lngHash)
  End If
  If (lngProv) Then
    Call CryptReleaseContext(lngProv, 0)
  End If
  hmac = strHex
End Function

Private Sub hmac_test()
  Debug.Print hmac("key", "data")
End Sub

win32apiを使っているので、こっちが早いと思います。