VBAでハッシュの計算

 概要

advapi32.dllを呼び出すことで、ハッシュ値を取得できるとの情報を見かけたため、試してみました。

備忘録として、コードを貼り付けておきます。

Option Compare Database
Option Explicit
#If VBA7 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
#If VBA7 Then
    Dim hProv As LongPtr, hHash As LongPtr
#Else
    Dim hProv As Long, 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
    strHash = ""
    If CryptAcquireContext(hProv, vbNullString, vbNullString, _
                           IIf(lngAlgID >= CALG_SHA_256, PROV_RSA_AES, PROV_RSA_FULL), _
                           CRYPT_VERIFYCONTEXT) <> 0& Then
        If CryptCreateHash(hProv, lngAlgID, 0&, 0&, hHash) <> 0& Then
            lngLength = UBound(abytData()) - LBound(abytData()) + 1
            If lngLength > 0 Then lngResult = CryptHashData(hHash, abytData(LBound(abytData())), lngLength, 0&) _
                             Else lngResult = CryptHashData(hHash, ByVal 0&, 0&, 0&)
            If lngResult <> 0& Then
                lngLength = UBound(abytHash()) - LBound(abytHash()) + 1
                If CryptGetHashParam(hHash, HP_HASHVAL, abytHash(LBound(abytHash())), lngLength, 0&) <> 0& Then
                    For i = 0 To lngLength - 1
                        strHash = strHash & Right$("0" & Hex$(abytHash(LBound(abytHash()) + i)), 2)
                    Next
                End If
            End If
            CryptDestroyHash hHash
        End If
        CryptReleaseContext hProv, 0&
    End If
    CreateHash = LCase$(strHash)
End Function

' Create Hash From String(SJIS->Unicode変換付き)
Private Function CreateHashString(ByVal strData As String, ByVal lngAlgID As Long) As String
    CreateHashString = CreateHash(StrConv(strData, vbFromUnicode), lngAlgID)
End Function

' Create Hash From File
Private Function CreateHashFile(ByVal strFileName As String, ByVal lngAlgID As Long) As String
    Dim abytData() As Byte
    Dim intFile As Integer
    Dim lngError As Long
    On Error Resume Next
    
        Dim FSO As New FileSystemObject
    
        'If Len(Dir(strFileName)) > 0 Then
        If FSO.FileExists(strFileName) Then
            intFile = FreeFile
            Open strFileName For Binary Access Read Shared As #intFile
            'abytData() = InputB(LOF(intFile), #intFile)
            
            Dim nLen As Long
            nLen = LOF(intFile)
            If nLen > 1 Then
                ReDim abytData(0 To nLen - 1)
                Get #intFile, , abytData
            Else
                abytData() = InputB(LOF(intFile), #intFile)
            End If

            
            Close #intFile
        End If
        lngError = Err.Number
    On Error GoTo 0
    If lngError = 0 Then CreateHashFile = CreateHash(abytData(), lngAlgID) _
                    Else CreateHashFile = ""
End Function

' MD5
Public Function CreateMD5Hash(abytData() As Byte) As String
    CreateMD5Hash = CreateHash(abytData(), CALG_MD5)
End Function
Public Function CreateMD5HashString(ByVal strData As String) As String
    CreateMD5HashString = CreateHashString(strData, CALG_MD5)
End Function
Public Function CreateMD5HashFile(ByVal strFileName As String) As String
    CreateMD5HashFile = CreateHashFile(strFileName, CALG_MD5)
End Function

' SHA-1
Public Function CreateSHA1Hash(abytData() As Byte) As String
    CreateSHA1Hash = CreateHash(abytData(), CALG_SHA)
End Function
Public Function CreateSHA1HashString(ByVal strData As String) As String
    CreateSHA1HashString = CreateHashString(strData, CALG_SHA)
End Function
Public Function CreateSHA1HashFile(ByVal strFileName As String) As String
    CreateSHA1HashFile = CreateHashFile(strFileName, CALG_SHA)
End Function

' SHA-256
Public Function CreateSHA256Hash(abytData() As Byte) As String
    CreateSHA256Hash = CreateHash(abytData(), CALG_SHA_256)
End Function
Public Function CreateSHA256HashString(ByVal strData As String) As String
    CreateSHA256HashString = CreateHashString(strData, CALG_SHA_256)
End Function
Public Function CreateSHA256HashFile(ByVal strFileName As String) As String
    CreateSHA256HashFile = CreateHashFile(strFileName, CALG_SHA_256)
End Function

' SHA-384
Public Function CreateSHA384Hash(abytData() As Byte) As String
    CreateSHA384Hash = CreateHash(abytData(), CALG_SHA_384)
End Function
Public Function CreateSHA384HashString(ByVal strData As String) As String
    CreateSHA384HashString = CreateHashString(strData, CALG_SHA_384)
End Function
Public Function CreateSHA384HashFile(ByVal strFileName As String) As String
    CreateSHA384HashFile = CreateHashFile(strFileName, CALG_SHA_384)
End Function

' SHA-512
Public Function CreateSHA512Hash(abytData() As Byte) As String
    CreateSHA512Hash = CreateHash(abytData(), CALG_SHA_512)
End Function
Public Function CreateSHA512HashString(ByVal strData As String) As String
    CreateSHA512HashString = CreateHashString(strData, CALG_SHA_512)
End Function
Public Function CreateSHA512HashFile(ByVal strFileName As String) As String
    CreateSHA512HashFile = CreateHashFile(strFileName, CALG_SHA_512)
End Function

コメント

コメントを投稿

このブログの人気の投稿

バーコードフォントを使用してCODE-128のバーコードを作成する

バーコードリーダーを使って入力の手間を省きたいと思う。 Excelで印刷イメージを作成する場合、CODE39のバーコードフォントを使用したり、バーコードのオブジェクトを使用する方法が簡単である。 ただし、CODE39では取り扱える文字が限定されていたり、環境によりExcelのバーコードオブジェクトが使用できない、等の事情がある場合もある。 文字数が多いCODE128を、バーコードフォントを使用してい印刷する場合、いくらか工夫が必要になる。 ・チェック文字の問題：　計算の必要がある。バーコードリーダーの設定が可能であれば、チェック文字を省くことで対応も可能 ・フォントによる文字コードとパターンの対応の違い：　使用するフォントにより文字コードとパターンの対応が異なるため、使用するフォントに従って変換が必要。 チェック文字の計算や、文字コードの対応の違いなど、（コードセットB限定にすれば）Excelの関数(LET＋α）で対応が出来たが、VBAでの計算・変換も試してみた。 使用するフォントは、0～94のコードが、32～126までの文字のパターン、95～105が、195～205の文字のパターン、終端が206の文字のパターンに割り振られていることを想定している。 Option Explicit ' CODE-128 バーコード ' ' GS-1 制限：先頭にFNC1、最大データ容量48文字 ' '入力 ASCII ' 0-127 ' ' EncodeCtrlAsc ' EncodeCtrlCode128 ' EncodeCode128 ' AddCheckSum ' FontCode ' ' 'encode ASCII, Code128 系の文字列＞文字変換 ' FUNC = 195(#95 a127), 196-205,206(#96 - #105,ed) ' $ Code128系特殊コード ' $$ $ ' $96-$106 これが、196-206に変換される ' $[STARTA] $103 2...
続きを読む

Selenium Basic から Edge を使用したときの「Webエクスペリエンスのカスタマイズ」を非表示にする

Selenium にて、 EdgeWebDriver を使用して、Edge(chrome)を操作したとき、「Webエクスペリエンスのカスタマイズ」のウインドウが表示される現象が起きた。 【現象の整理】 ・通常に(Seleniumではなく手動で)Edgeを起動したときは、初回のみ表示される ・Selenium から起動したときは、毎回表示される ・表示されるページが、意図しないページになることがある。 【問題】 ・SendKeys などを使うときに問題となる。 ・Selenium にて、Get しても指定したページが開かないことがある。 【調査】 調べてみると以下の情報があった。 ・Selenium では、ユーザーのプロファイルは、起動毎に作成・廃棄される。 ・Selenium の起動時にユーザープロファイルを指定する方法がある。 通常起動時に、２回目以降表示されないため、ユーザープロファイルが関係していると推理。 Selenium からの起動時にユーザープロファイルを指定することで、ユーザープロファイルが保持されるようになり、「Webエクスペリエンスのカスタマイズ」が表示されなくなるか、検証することとした。 【検証】 ユーザープロファイルを指定して起動。 初回起動時に「Webエクス～」が表示されるため確認。 ２回目以降は表示されないことを確認した。     Dim driver As New Selenium.EdgeDriver     Dim elmDoc As Selenium.WebElement          driver.AddArgument "--user-data-dir=任意のフォルダ"     driver.AddArgument "--profile-directory=任意のフォルダ２"          With driver         .Start                   .Get "http://任意のアドレス"   ...
続きを読む

[VBScript]WiFiアダプタの無効化と有効化をスクリプトで実行する

OSをWindows10に入れ替えてから、起動直後やスリープからの復帰時に「識別中・・・インターネットアクセスなし」と表示され、インターネットに接続できない現象に遭遇しています。 結構な頻度で発生し、Wifiのネットワークアダプタを一度無効にしてから有効にすると治ります。 面倒な操作ですが、その後は安定するため、Wifiアダプタの買い替えまでには踏み切れません。 別件の調べ物をしていたら、WMIで無効・有効を操作できそうだったので、VBScriptで試してみました。 本題 VBScriptからWifiのネットワークアダプタを再接続（無効化→有効化）する。 ＜使い方＞ ・適当なファイル名(~.vbs）に保存し、ダブルクリックで実行。 ・ネットワークアダプタの名称に合わせて、検索条件（ %Wireless%の箇所）は適宜変更すること。 ・バッチファイルを作成し、起動後にスケジュール実行するようにしても良いかもしれません。無効・有効の設定には、管理者権限が必要なようです。 ポイント ・VBScriptからWMIを利用。Wifiアダプタの検索と設定が、比較的簡単。 ・アダプタの無効と有効の間に、何となくウェイトを入れています。根拠はありません。 Option Explicit Dim obj Set obj = Wscript.CreateObject("Shell.Application") if Wscript.Arguments.Count = 0 then ' 管理者権限でスクリプトを再実行する obj.ShellExecute "wscript.exe", WScript.ScriptFullName & " runas", "", "runas", 1 Wscript.Quit end if 'WMIにて使用する各種オブジェクトを定義・生成する。 Dim oClassSet Dim oClass Dim oLocator Dim oService 'ローカルコンピュータに接続する。 Set oLocator = WScript.CreateObject("WbemScripting.S...
続きを読む