★ExcelVBA ～【電子帳簿保存法・タイムスタンプがらみ】ファイルのハッシュ値をゲットする関数

※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。

参考
紙でもらった請求書はPDF化しないといけないか？→不要。
PDFやExcelなど、電子データでもらった請求書は紙にしていいか？→紙だけじゃダメ。デジタルデータのほうを保管しないといけない。
結局、「全部紙でちょうだい」が「何もしなくていい」となります。
ただし、せっかくもらった紙を「PDF化してしまう」と、
保存要件の対象になってしまうので、紙でもらったものは必ず紙のみで保管する。

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

以下、本文です。

電子帳簿保存法の「電子データで交付や受取をした取引のデータ保存の義務化」について、猶予期間が、本年、2023年12月31日に終わります。

年明け・2024年1月1日からは、
「電子データで交付や受取をした取引のデータ保存」が「完全義務化」となります。
「紙に印刷して保存Only」が法的に「ダメ・違法」になります。
（※電子データのままの保存がちゃんとしてあれば、追加で紙に印刷することは違法ではない。万が一のために重要書類だけ電子と紙の両方で保管することは違法ではない。管理が大変になるかもしれませんけど。）

もちろん、その対象は「電子データでもらったもの」「だけ」です。
紙でもらった請求書は紙のままでOKです。PDF化する必要はないし、PDF化すると逆に「法律上の保存システム」が必要になってしまうので、むしろPDF化などをしてはいけません。

で、結局どのような方法が義務付けられるのかというと、結論から言うと、
「社内規約さえ作っておけばいい」
です。

基本的には、「もらったデータ（PDF等）を絶対に編集・改ざんしない」という原則にして、そういった、「取り扱いのルール（＝社内規約書）」を書いたものを用意して、「日付、取引先、金額」での検索がすぐにできる状態におけば、巷でよく言われている「有料のタイムスタンプ付加」などは不要のようです。
（ただし、それは請求書や見積書などの書類のみ。「電子契約書」などの場合は別。「電子契約書」などの場合はタイムスタンプなどが必須。）

※参考：国税庁HP ～問9　電子取引の取引情報に係る電磁的記録の保存等を行う場合には、どのような要件を満たさなければならないのでしょうか。

以下、要件の引用です。↓


	電子計算機処理システムの概要を記載した書類の備付け（自社開発のプログラムを使用する場合に限ります。）(規３三イ、七、８)　→★【自社オリジナルシステムの場合のみ、必須。市販ビジネスソフトの場合等は不要。】保存システム（保存機能）の概要・操作方法など
見読可能装置の備付け等(規３四、８)　→★【必須】パソコンなどのPDF等がよめる機器の準備
検索機能の確保(規３五、七、８)　→★【必須】「日付、金額、取引先」がすぐに検索できる機能の準備。
次のいずれかの措置を行う（規８）　→★【必須】ただ、「いずれか」なので、「４」だけでもOK。一　タイムスタンプが付された後の授受二　授受後遅滞なくタイムスタンプを付す三　データの訂正削除を行った場合にその記録が残るシステム又は訂正削除ができないシステムを利用四　訂正削除の防止に関する事務処理規程の備付け

上記の表の、一番下の、「四　訂正削除の防止に関する事務処理規程の備付け」が
前述した、
『基本的には、「もらったデータ（PDF等）を絶対に編集・改ざんしない」という原則にして、そういった、「取り扱いのルール（＝社内規約書）」』
ということになります。

ただ、そのとき、「絶対に編集させない」ということを「助ける」意味で、「電帳法が言うところのタイムスタンプ」、「ファイルのハッシュ値と更新日付」を記録しておくのは１つの方法だと思います。
もちろん、Acrobat Readerで無料のタイムスタンプを付ける方法もよいかと思います。

参考：Acrobat Readerで無料のタイムスタンプを付けた場合の証拠？のミニ画面
　　　　↓

ただし、無料のタイムスタンプは、あくまでも、
電子契約書以外の電子データにて、
「四　訂正削除の防止に関する事務処理規程の備付け」、をする場合の、
「単に、より改ざんを予防するためだけの」、
「補完機能」、
としてでしか使ってはいけません。

「Acrobat Readerで無料でタイムスタンプを付ける方法」はタイムサーバーが国税庁が認めないタイプのサーバーの恐れもあるため、電子契約書には使えないかもしれません。だからです。
なので、もし無料のタイムスタンプを付けるなら、アクロバットではなくて、「みんなのタイムスタンプ」みたいなものが良いのかもしれません。

参考：みんなのタイムスタンプ

Acrobat Readerの無料タイムスタンプだと、結局、あとになって、
「このサーバーのタイムスタンプだと、要件を満たしたことにならないので、ここに保存してあるPDFは全部違法です」、
と言われてしまう恐れがあります。ぞっとしますね(^^)

そうならないようにするために、以下のようなことが必要だと思われます。

(01)電子契約書などの有料のタイムスタンプが必要な書類には、
　　しっかり有料のタイムスタンプを付ける。
　　無料なら、「みんなのタイムスタンプ」のようなサービス？

(02)電子契約書以外の、タイムスタンプが不要な書類には、
　　社内規約で対応し、保険（改ざん予防策）として無料のタイムスタンプか、
　　後述のような関数を使って、「ファイルのハッシュ値＋更新日付」などの記録、
　　保管しておくといいと思います。

今回のプログラムは、上記の(02)に使うためのモノです。
（「みんなのタイムスタンプ」のような「Webに自社の書類をアップすること自体が嫌だ、怖い」、と言う場合も、使えるかもしれません。予防策としてだけ。）

ではこれ以下に、「指定したファイルからハッシュ値を取得する関数のあれこれ」、
をご紹介します。
（日付を付加まではしていませんので、その部分はまた自作する必要があります。）

●コマンドプロンプトでのハッシュ値の割り出しの実行結果をVBA側に受け取る方式
（※受け取り先が「配列」の方法）

（※コマンドを実行したあと、その結果の「数行」からハッシュ値だけを抽出
　　するコードも一緒になっています。SHA256以上でも計算できます。）

これはコマンドプロンプトのコマンドを利用する方法です。
（API利用での方法はこちら→スーの道具箱/気まぐれ日記/2007-03-08）

基本、この方式は、主に7、8、10、11、で使えます。
Windows2000SP4Pro（他のバージョン未確認）や、XP、でも使えるかもしれませんが、
未確認です。使えないかもしれません。
後述の「GetFileHashSha1()」関数、「GetFileHashSha1ForWin2000()」関数のほうが簡単かもしれません。

このプログラムはそこそこ速いです。
のちの「APIを使う方法」の2倍は速いです。
「.NetFrameWork3.5」を使う方法よりは若干遅いかも？しれません。
なお、コマンドの実行時に黒い画面がちらつきますので、
それが嫌な方は「.NetFrameWork3.5」を使う方法にしてみてください。

なお、この方法は、Windows2000SP4Pro（他のバージョン未確認）、XPの場合、
「SHA1」しかハッシュ値の計算ができません。
MD5もできるかもしれませんが未確認です。
（7や8は未確認です。Win10、11なら、SHA256以上のハッシュ値計算ができます。）

ただ、「SHA1」は、Googleのどこかのチームが2017年にようやく突破した、
というものですので、一般の会社であればそんな力がある会社は少ないと思いますから、
現実的には「SHA1」で十分、「原本保証」になるかと思います。
「SHA1」以前の、「MD5」というより脆弱性のあるハッシュ計算方式ですら、
「実際の裁判では」「ファイルが改ざんされた」と「証明するほうが困難」…、
だそうです。
下記のURLは、そのことが書かれたWebページですが、
「mhtml形式などでの保存が必須」というくらいの良い内容です。
是非、保存しておいてください。
↓
ＩＴの知識不足による判決間違い？－ＭＤ５の脆弱性

基本、XPでは、通常はすぐには使えないかもです。
しかし、
「Windows Server 2003 Service Pack 2 管理ツールパック (x86 エディション用)」
https://www.microsoft.com/ja-jp/download/details.aspx?id=6315
をダウンロード、インストールすると、
動くようになるかも？です。

その際、すべてのPCにそれをインストールしなくてもOKです。
どれか１つのPCにインストールし、その完了後に、最低限必要なファイルを
２つ抜き出して、他のマシンには、それをコピペすればOKです。
（「c:\windows\system32」に。）

その２つのファイルは、
「c:\windows\system32」の、「certutil.exe」と「certadm.dll」です。

2000の場合も似ようなコードでやれます。
（SP4のPro版しか確認取れてません。後述の「GetFileHashSha1ForWin2000()」関数です。）

で、2000SP4のPro版ではその２つのファイルはすでに入っているようですが、
ただし、格納場所（「C:\WINNT\system32\dllcache」）にPATHが
通ってないので機能しません。
機能させるには（「C:\WINNT\system32\dllcache」）にPATHを通して、
余計な同名のファイルをリネームすると、使えることがあるようです。
（PATHを通す方法は後述します。）

ただ、このプログラムはPATHが通っていても、2000系でちゃんと動くかはわかりません。
動くかもしれないし、動かないかもしれません。
はっきりしていますのは、後述の「GetFileHashSha1ForWin2000()」関数のほうなら
確実だということです。

'
'
'
Option Explicit

'指定したファイルのハッシュ値を、指定したセルに書き出す関数
'
'呼び出し方
'Call AddHashResult("ファイルパス", "ハッシュアルゴリズム", 出力先の単一セルのオブジェクト式)
'
'【例】↓
'Call AddHashResult("d:\1\タイムスタンプテスト01-01.pdf", "sha256", ActiveSheet.Range("B5"))

Function AddHashResult(s_FilePath As String, _
                       s_HashStyle As String, _
                       o_Cell As Range)

    Dim v_HashResultAry As Variant
    Dim s_Result01 As String
    Dim s_Result02 As String
    
    v_HashResultAry = v_GetFileHash(s_FilePath, s_HashStyle)
       
    o_Cell.Value = v_HashResultAry(1)

End Function


'--------------------------------------------------------------------------------
'引数で指定したファイルのハッシュ値（ダイジェスト値）等を、
'Variant型の1次元配列で返します。
'
' s_FilePath：ファイルパス。テキスト型のリテラルで指定。
' s_HashAlgo：ハッシュアルゴリズムの種類。MD5,SHA1,SHA256などをテキスト型のリテラルで指定。
' v_GetFileHash：コマンドの結果が配列で格納されます。
'　　要素(0)は検証したファイルのパスなど、が返り、
'　　要素(1)は検証したファイルのハッシュ値、が返ります。
'--------------------------------------------------------------------------------
Public Function v_GetFileHash(s_FilePath As String, s_HashAlgo As String) As Variant

    Dim o_WSH As Object
    Dim o_wshExec As Object
    Dim s_Cmd As String
    Dim s_Output As String

    Set o_WSH = CreateObject("WScript.Shell")
    s_Cmd = "certutil -hashfile " & _
            """" & s_FilePath & """" & _
            " " & s_HashAlgo & _
            " | findstr /V CertUtil | findstr /V " & _
            s_HashAlgo
    
    
    Set o_wshExec = o_WSH.Exec("%ComSpec% /c " & s_Cmd)

    Do While o_wshExec.Status = 0
        DoEvents
    Loop

    s_Output = o_wshExec.stdOut.ReadAll
    
    Dim s_OutptStr01 As String
    Dim s_OutptStr02 As String
    
'    Stop
    
    s_OutptStr01 = Left(s_Output, InStr(1, s_Output, vbCrLf))
    s_OutptStr01 = Replace(s_OutptStr01, vbCrLf, "", , , vbBinaryCompare)
    s_OutptStr01 = Replace(s_OutptStr01, vbLf, "", , , vbBinaryCompare)
    s_OutptStr01 = Replace(s_OutptStr01, vbCr, "", , , vbBinaryCompare)
    
    
    s_OutptStr02 = Replace(s_Output, s_OutptStr01, "", , , vbBinaryCompare)
    s_OutptStr02 = Replace(s_OutptStr02, vbCrLf, "", , , vbBinaryCompare)
    s_OutptStr02 = Replace(s_OutptStr02, vbLf, "", , , vbBinaryCompare)
    s_OutptStr02 = Replace(s_OutptStr02, vbCr, "", , , vbBinaryCompare)
    
    Set o_wshExec = Nothing
    Set o_WSH = Nothing

    v_GetFileHash = Array(s_OutptStr01, s_OutptStr02)

'    Stop
End Function



Sub GetHashResultAryTest01()

    Dim s_FilePath      As String
    Dim v_HashResultAry As Variant
    
    Let s_FilePath = "d:\1\タイムスタンプテスト01-01.pdf"
    v_HashResultAry = v_GetFileHash(s_FilePath, "sha256")

    Dim s_01 As String
    Dim s_02 As String
    
    s_01 = v_HashResultAry(0)
    s_02 = v_HashResultAry(1)
    
    Debug.Print InStr(1, v_HashResultAry(0), vbCrLf)
    Debug.Print InStr(1, v_HashResultAry(1), vbCrLf)
    Debug.Print s_01
    Debug.Print s_02
    
End Sub




'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

Option Explicit

'指定したファイルのハッシュ値を、指定したセルに書き出す関数

'呼び出し方

'Call AddHashResult("ファイルパス", "ハッシュアルゴリズム", 出力先の単一セルのオブジェクト式)

'【例】↓

'Call AddHashResult("d:\1\タイムスタンプテスト01-01.pdf", "sha256", ActiveSheet.Range("B5"))

Function AddHashResult(s_FilePath As String, _

s_HashStyle As String, _

o_Cell As Range)

Dim v_HashResultAry As Variant

Dim s_Result01 As String

Dim s_Result02 As String

v_HashResultAry = v_GetFileHash(s_FilePath, s_HashStyle)

o_Cell.Value = v_HashResultAry(1)

End Function

'--------------------------------------------------------------------------------

'引数で指定したファイルのハッシュ値（ダイジェスト値）等を、

'Variant型の1次元配列で返します。

' s_FilePath：ファイルパス。テキスト型のリテラルで指定。

' s_HashAlgo：ハッシュアルゴリズムの種類。MD5,SHA1,SHA256などをテキスト型のリテラルで指定。

' v_GetFileHash：コマンドの結果が配列で格納されます。

'　　要素(0)は検証したファイルのパスなど、が返り、

'　　要素(1)は検証したファイルのハッシュ値、が返ります。

'--------------------------------------------------------------------------------

Public Function v_GetFileHash(s_FilePath As String, s_HashAlgo As String) As Variant

Dim o_WSH As Object

Dim o_wshExec As Object

Dim s_Cmd As String

Dim s_Output As String

Set o_WSH = CreateObject("WScript.Shell")

s_Cmd = "certutil -hashfile " & _

"""" & s_FilePath & """" & _

" " & s_HashAlgo & _

" | findstr /V CertUtil | findstr /V " & _

s_HashAlgo

Set o_wshExec = o_WSH.Exec("%ComSpec% /c " & s_Cmd)

Do While o_wshExec.Status = 0

DoEvents

Loop

s_Output = o_wshExec.stdOut.ReadAll

Dim s_OutptStr01 As String

Dim s_OutptStr02 As String

' Stop

s_OutptStr01 = Left(s_Output, InStr(1, s_Output, vbCrLf))

s_OutptStr01 = Replace(s_OutptStr01, vbCrLf, "", , , vbBinaryCompare)

s_OutptStr01 = Replace(s_OutptStr01, vbLf, "", , , vbBinaryCompare)

s_OutptStr01 = Replace(s_OutptStr01, vbCr, "", , , vbBinaryCompare)

s_OutptStr02 = Replace(s_Output, s_OutptStr01, "", , , vbBinaryCompare)

s_OutptStr02 = Replace(s_OutptStr02, vbCrLf, "", , , vbBinaryCompare)

s_OutptStr02 = Replace(s_OutptStr02, vbLf, "", , , vbBinaryCompare)

s_OutptStr02 = Replace(s_OutptStr02, vbCr, "", , , vbBinaryCompare)

Set o_wshExec = Nothing

Set o_WSH = Nothing

v_GetFileHash = Array(s_OutptStr01, s_OutptStr02)

' Stop

End Function

Sub GetHashResultAryTest01()

Dim s_FilePath As String

Dim v_HashResultAry As Variant

Let s_FilePath = "d:\1\タイムスタンプテスト01-01.pdf"

v_HashResultAry = v_GetFileHash(s_FilePath, "sha256")

Dim s_01 As String

Dim s_02 As String

s_01 = v_HashResultAry(0)

s_02 = v_HashResultAry(1)

Debug.Print InStr(1, v_HashResultAry(0), vbCrLf)

Debug.Print InStr(1, v_HashResultAry(1), vbCrLf)

Debug.Print s_01

Debug.Print s_02

End Sub

　　
●PATHを通すプログラム

後述の「PATH_Add01()」にて、できます。

●APIを使う方法32bit版（32bit版のExcel、Wordなどのみでしか使えません。）
（※コマンドプロンプト利用の方法ように、受けた結果が複数行にならないです。
　　普通の関数と同じく、文字列型のハッシュ値がまんまで返ってきます。）

以下、「スーの道具箱/気まぐれ日記/2007-03-08」が消えちゃうといけないので、メモ引用。

このプログラムは「遅い」ですが、Windows2000SP4ProでもXPsp2などでも使えます。
何の追加のdllやexeなどのファイルが要らないので、「容量が１MB以下の小さなファイルばかり」のときは、これで十分間に合います。

容量が１MB以上のファイル（特に２MB以上のファイル）が増えてきたら、
「certutil.exe」と「certadm.dll」などのファイルを使っての、
「コマンドプロンプトでのハッシュ値割出しの実行結果をVBA側に受け取る方式」
がいいと思います。
（この方式はXPやWin10などで使えますが、実行結果の行数が異なるため、
　それぞれ、　実行結果をVBA側に受け取るときのプログラムを少し
　変える必要があります。）

'
'
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 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_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_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
    Dim hProv As Long, hHash As Long
    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)
    
    Debug.Print strHash
    
End Function

' Create Hash From String(Shift_JIS)
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
        If Len(Dir(strFileName)) > 0 Then
            intFile = FreeFile
            Open strFileName For Binary Access Read Shared As #intFile
            abytData() = InputB(LOF(intFile), #intFile)
            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-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


'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

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 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_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_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

Dim hProv As Long, hHash As Long

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)

End If

CryptDestroyHash hHash

End If

CryptReleaseContext hProv, 0&

End If

CreateHash = LCase$(strHash)

Debug.Print strHash

End Function

' Create Hash From String(Shift_JIS)

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

If Len(Dir(strFileName)) > 0 Then

intFile = FreeFile

Open strFileName For Binary Access Read Shared As #intFile

abytData() = InputB(LOF(intFile), #intFile)

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-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

●APIを使う方法64bit版（64bit版のExcel、Wordなどのみでしか使えません。）
上記のプログラムを64bit版に直したものです。

このプログラムは「遅い」です。
また、64bitなので、XPSp2やWindows2000SP4Proなどのうち32bitのOSでは動きません。

'
'
Option Explicit

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 LongPtr, ByVal dwFlags AS LongPtr) AS LongPtr
Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32.dll" _
                            (ByVal hProv AS LongPtr, ByVal dwFlags AS LongPtr) AS LongPtr
Private Declare PtrSafe Function CryptCreateHash Lib "advapi32.dll" _
                            (ByVal hProv AS LongPtr, ByVal Algid AS LongPtr, ByVal hKey AS LongPtr, ByVal dwFlags AS LongPtr, _
                             ByRef phHash AS LongPtr) AS LongPtr
Private Declare PtrSafe Function CryptDestroyHash Lib "advapi32.dll" _
                            (ByVal hHash AS LongPtr) AS LongPtr
Private Declare PtrSafe Function CryptHashData Lib "advapi32.dll" _
                            (ByVal hHash AS LongPtr, pbData As Any, ByVal cbData AS LongPtr, ByVal dwFlags AS LongPtr) AS LongPtr
Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32.dll" _
                            (ByVal hHash AS LongPtr, ByVal dwParam AS LongPtr, pbData As Any, ByRef pcbData AS LongPtr, _
                             ByVal dwFlags AS LongPtr) AS LongPtr

Private Const PROV_RSA_FULL   AS LongPtr = 1
Private Const PROV_RSA_AES    AS LongPtr = 24
Private Const CRYPT_VERIFYCONTEXT AS LongPtr = &HF0000000

Private Const HP_HASHVAL      AS LongPtr = 2
Private Const HP_HASHSIZE     AS LongPtr = 4

Private Const ALG_TYPE_ANY    AS LongPtr = 0
Private Const ALG_CLASS_HASH  AS LongPtr = 32768

Private Const ALG_SID_MD2     AS LongPtr = 1
Private Const ALG_SID_MD4     AS LongPtr = 2
Private Const ALG_SID_MD5     AS LongPtr = 3
Private Const ALG_SID_SHA     AS LongPtr = 4
Private Const ALG_SID_SHA_256 AS LongPtr = 12
Private Const ALG_SID_SHA_384 AS LongPtr = 13
Private Const ALG_SID_SHA_512 AS LongPtr = 14

Private Const CALG_MD2        AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2)
Private Const CALG_MD4        AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4)
Private Const CALG_MD5        AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5)
Private Const CALG_SHA        AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA)
Private Const CALG_SHA_256    AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_256)
Private Const CALG_SHA_384    AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_384)
Private Const CALG_SHA_512    AS LongPtr = (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
    Dim hProv As Long, hHash As Long
    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)
    Debug.Print strHash
    
End Function

' Create Hash From String(Shift_JIS)
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
        If Len(Dir(strFileName)) > 0 Then
            intFile = FreeFile
            Open strFileName For Binary Access Read Shared As #intFile
            abytData() = InputB(LOF(intFile), #intFile)
            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-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

'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

Option Explicit

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 LongPtr, ByVal dwFlags AS LongPtr) AS LongPtr

Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32.dll" _

(ByVal hProv AS LongPtr, ByVal dwFlags AS LongPtr) AS LongPtr

Private Declare PtrSafe Function CryptCreateHash Lib "advapi32.dll" _

(ByVal hProv AS LongPtr, ByVal Algid AS LongPtr, ByVal hKey AS LongPtr, ByVal dwFlags AS LongPtr, _

ByRef phHash AS LongPtr) AS LongPtr

Private Declare PtrSafe Function CryptDestroyHash Lib "advapi32.dll" _

(ByVal hHash AS LongPtr) AS LongPtr

Private Declare PtrSafe Function CryptHashData Lib "advapi32.dll" _

(ByVal hHash AS LongPtr, pbData As Any, ByVal cbData AS LongPtr, ByVal dwFlags AS LongPtr) AS LongPtr

Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32.dll" _

(ByVal hHash AS LongPtr, ByVal dwParam AS LongPtr, pbData As Any, ByRef pcbData AS LongPtr, _

ByVal dwFlags AS LongPtr) AS LongPtr

Private Const PROV_RSA_FULL AS LongPtr = 1

Private Const PROV_RSA_AES AS LongPtr = 24

Private Const CRYPT_VERIFYCONTEXT AS LongPtr = &HF0000000

Private Const HP_HASHVAL AS LongPtr = 2

Private Const HP_HASHSIZE AS LongPtr = 4

Private Const ALG_TYPE_ANY AS LongPtr = 0

Private Const ALG_CLASS_HASH AS LongPtr = 32768

Private Const ALG_SID_MD2 AS LongPtr = 1

Private Const ALG_SID_MD4 AS LongPtr = 2

Private Const ALG_SID_MD5 AS LongPtr = 3

Private Const ALG_SID_SHA AS LongPtr = 4

Private Const ALG_SID_SHA_256 AS LongPtr = 12

Private Const ALG_SID_SHA_384 AS LongPtr = 13

Private Const ALG_SID_SHA_512 AS LongPtr = 14

Private Const CALG_MD2 AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2)

Private Const CALG_MD4 AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4)

Private Const CALG_MD5 AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5)

Private Const CALG_SHA AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA)

Private Const CALG_SHA_256 AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_256)

Private Const CALG_SHA_384 AS LongPtr = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_384)

Private Const CALG_SHA_512 AS LongPtr = (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

Dim hProv As Long, hHash As Long

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)

End If

CryptDestroyHash hHash

End If

CryptReleaseContext hProv, 0&

End If

CreateHash = LCase$(strHash)

Debug.Print strHash

End Function

' Create Hash From String(Shift_JIS)

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

If Len(Dir(strFileName)) > 0 Then

intFile = FreeFile

Open strFileName For Binary Access Read Shared As #intFile

abytData() = InputB(LOF(intFile), #intFile)

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-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

●.NET FrameWork3.5を利用した方法（XP以降？で使える？）
（※コマンドプロンプトもAPIも使わずに、「.NET FrameWork3.5」を使った方法です。
　　Win10以上などなら、この方式が一番いいかも？しれません。
　　もしかしたら、Windows7以上なら、？ということかもしれません。
「.NET FrameWork3.5」が入ってさえすればいいので。）

動作速度が前述の方法よりも速い気がします。
（「File2SHA1$」関数など。）

https://www.google.com/search?q=VBA+System.Security.Cryptography+%E3%83%8F%E3%83%83%E3%82%B7%E3%83%A5+%E8%A8%88%E7%AE%97&rlz=1C1AGAK_jaJP986JP986&oq=VBA+System.Security.Cryptography+%E3%83%8F%E3%83%83%E3%82%B7%E3%83%A5+%E8%A8%88%E7%AE%97&gs_lcrp=EgZjaHJvbWUyBggAEEUYOTIKCAEQABiiBBiJBTIKCAIQABiABBiiBNIBCTEyMjY1ajBqN6gCALACAA&sourceid=chrome&ie=UTF-8

https://www.se-https://blog.nekonium.com/vba-hash/

「.NET Framework 3.5が有効になっていることを確認しましょう。」
とあるので、それがインストールされていて、
「プログラムと機能」の「Windowsの機能の有効化または無効化」にて
有効になってないとダメっぽいです。

「.NET Framework 3.5を有効にする方法」
https://www.depthbomb.net/?p=8611#toc3

ダウンロードセンターの、
「.NET Framework 3.5 Service Pack 1 (フルパッケージ：２３１MB：ダウンロード可能）」
https://www.microsoft.com/ja-jp/download/details.aspx?id=25150 や
http://go.microsoft.com/fwlink/?LinkId=122089 には、
システム必要条件に
「対応オペレーティングシステム Windows Server 2003, Windows Server 2008, Windows Vista, Windows XP」
とあるので、もしかしたら、XPでも行けるかもしれません。

'
'

'★ファイルに使えるプログラム

Option Explicit


Private Const SHA1_LENGTH = 20
Private Const SHA1_LENGTH_AS_STRING = 40
Private Const SHA256_LENGTH = 32
Private Const SHA256_LENGTH_AS_STRING = 64

Private objUTF8 As Object
Private objSHA256 As Object
Private objSHA1 As Object

'文字列からハッシュを計算する関数
Public Function String2SHA256$(str$)

    '必要ならオブジェクトを初期化してエンコード
    If objUTF8 Is Nothing Then
        Set objUTF8 = CreateObject("System.Text.UTF8Encoding")
    End If
    Dim code() As Byte
    code = objUTF8.GetBytes_4(str)

    '必要ならオブジェクトを初期化してハッシュを計算
    If objSHA256 Is Nothing Then
        Set objSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
    End If
    Dim hashValue() As Byte
    hashValue = objSHA256.ComputeHash_2(code)

    '16進法表示に変換
    Dim description As String * SHA256_LENGTH_AS_STRING
    Dim i&
    For i = 0 To SHA256_LENGTH - 1
        Mid(description, i * 2 + 1) = Right("0" & Hex(hashValue(i)), 2)
    Next i

    String2SHA256 = description

End Function


'ファイル(のフルパス)から「SHA256」のハッシュを計算する関数
Public Function File2SHA256$(fullPath$)

    '指定したファイルがあるかどうか確認
    Dim targetFileExists As Boolean
    targetFileExists = Len(Dir(fullPath)) <> 0
    If Not targetFileExists Then GoTo NoSuchFile

    'ファイル読み込み
    Dim buff() As Byte
    Dim ff&
    ff = FreeFile
    Open fullPath For Binary Lock Read As #ff
    ReDim buff(LOF(ff) - 1)
    Get #ff, , buff
    Close #ff

    '必要ならオブジェクトを初期化してハッシュを計算
    If objSHA256 Is Nothing Then
        Set objSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
    End If
    Dim hashValue() As Byte
    hashValue = objSHA256.ComputeHash_2(buff)

    '16進法表示に変換
    Dim description As String * SHA256_LENGTH_AS_STRING
    Dim i&
    For i = 0 To SHA1_LENGTH - 1
        Mid(description, i * 2 + 1) = Right("0" & Hex(hashValue(i)), 2)
    Next i

    File2SHA256 = description
Exit Function

NoSuchFile:
    MsgBox "そんなファイルないよ。"
End Function


'ファイル(のフルパス)から「SHA1」のハッシュを計算する関数
Public Function File2SHA1$(fullPath$)

    '指定したファイルがあるかどうか確認
    Dim targetFileExists As Boolean
    targetFileExists = Len(Dir(fullPath)) <> 0
    If Not targetFileExists Then GoTo NoSuchFile

    'ファイル読み込み
    Dim buff() As Byte
    Dim ff&
    ff = FreeFile
    Open fullPath For Binary Lock Read As #ff
    ReDim buff(LOF(ff) - 1)
    Get #ff, , buff
    Close #ff

    '必要ならオブジェクトを初期化してハッシュを計算
    If objSHA1 Is Nothing Then
        Set objSHA1 = CreateObject("System.Security.Cryptography.SHA1Managed")
    End If
    Dim hashValue() As Byte
    hashValue = objSHA1.ComputeHash_2(buff)

    '16進法表示に変換
    Dim description As String * SHA1_LENGTH_AS_STRING
    Dim i&
    For i = 0 To SHA1_LENGTH - 1
        Mid(description, i * 2 + 1) = Right("0" & Hex(hashValue(i)), 2)
    Next i

    File2SHA1 = description
Exit Function

NoSuchFile:
    MsgBox "そんなファイルないよ。"
End Function



==================================================


'★ファイルに使えるかどうかわからないプログラム


Option Explicit

Sub test()
    
   Debug.Print UCase(HASH_SHA1("D:\1\123.accdb"))

   Call CreateSHA1HashFile("D:\1\123.accdb")
   
End Sub

Public Function HASH_SHA256(str As String) As String
    Dim sha256m As Object
    Dim utf8 As Object
    Dim bytes() As Byte
    Dim hash() As Byte
    Dim i As Integer
    Dim res As String

    Set utf8 = CreateObject("System.Text.UTF8Encoding")
    bytes = utf8.GetBytes_4(str)

    Set sha256m = CreateObject("System.Security.Cryptography.SHA256Managed")
    hash = sha256m.ComputeHash_2((bytes))

    For i = LBound(hash) To UBound(hash)
        res = res & LCase(Right("0" & Hex(hash(i)), 2))
    Next i

    HASH_SHA256 = LCase(res)
End Function


Public Function HASH_SHA1(str As String) As String
    Dim sha1m As Object
    Dim utf8 As Object
    Dim bytes() As Byte
    Dim hash() As Byte
    Dim i As Integer
    Dim res As String

    Set utf8 = CreateObject("System.Text.UTF8Encoding")
    bytes = utf8.GetBytes_4(str)

    Set sha1m = CreateObject("System.Security.Cryptography.SHA1Managed")
    hash = sha1m.ComputeHash_2((bytes))

    For i = LBound(hash) To UBound(hash)
        res = res & LCase(Right("0" & Hex(hash(i)), 2))
    Next i

    HASH_SHA1 = LCase(res)
End Function



==================================================

'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

'★ファイルに使えるプログラム

Option Explicit

Private Const SHA1_LENGTH = 20

Private Const SHA1_LENGTH_AS_STRING = 40

Private Const SHA256_LENGTH = 32

Private Const SHA256_LENGTH_AS_STRING = 64

Private objUTF8 As Object

Private objSHA256 As Object

Private objSHA1 As Object

'文字列からハッシュを計算する関数

Public Function String2SHA256$(str$)

'必要ならオブジェクトを初期化してエンコード

If objUTF8 Is Nothing Then

Set objUTF8 = CreateObject("System.Text.UTF8Encoding")

End If

Dim code() As Byte

code = objUTF8.GetBytes_4(str)

'必要ならオブジェクトを初期化してハッシュを計算

If objSHA256 Is Nothing Then

Set objSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")

End If

Dim hashValue() As Byte

hashValue = objSHA256.ComputeHash_2(code)

'16進法表示に変換

Dim description As String * SHA256_LENGTH_AS_STRING

Dim i&

For i = 0 To SHA256_LENGTH - 1

Mid(description, i * 2 + 1) = Right("0" & Hex(hashValue(i)), 2)

Next i

String2SHA256 = description

End Function

'ファイル(のフルパス)から「SHA256」のハッシュを計算する関数

Public Function File2SHA256$(fullPath$)

'指定したファイルがあるかどうか確認

Dim targetFileExists As Boolean

targetFileExists = Len(Dir(fullPath)) <> 0

If Not targetFileExists Then GoTo NoSuchFile

'ファイル読み込み

Dim buff() As Byte

Dim ff&

ff = FreeFile

Open fullPath For Binary Lock Read As #ff

ReDim buff(LOF(ff) - 1)

Get #ff, , buff

Close #ff

'必要ならオブジェクトを初期化してハッシュを計算

If objSHA256 Is Nothing Then

Set objSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")

End If

Dim hashValue() As Byte

hashValue = objSHA256.ComputeHash_2(buff)

'16進法表示に変換

Dim description As String * SHA256_LENGTH_AS_STRING

Dim i&

For i = 0 To SHA1_LENGTH - 1

Mid(description, i * 2 + 1) = Right("0" & Hex(hashValue(i)), 2)

Next i

File2SHA256 = description

Exit Function

NoSuchFile:

MsgBox "そんなファイルないよ。"

End Function

'ファイル(のフルパス)から「SHA1」のハッシュを計算する関数

Public Function File2SHA1$(fullPath$)

'指定したファイルがあるかどうか確認

Dim targetFileExists As Boolean

targetFileExists = Len(Dir(fullPath)) <> 0

If Not targetFileExists Then GoTo NoSuchFile

'ファイル読み込み

Dim buff() As Byte

Dim ff&

ff = FreeFile

Open fullPath For Binary Lock Read As #ff

ReDim buff(LOF(ff) - 1)

Get #ff, , buff

Close #ff

'必要ならオブジェクトを初期化してハッシュを計算

If objSHA1 Is Nothing Then

Set objSHA1 = CreateObject("System.Security.Cryptography.SHA1Managed")

End If

Dim hashValue() As Byte

hashValue = objSHA1.ComputeHash_2(buff)

'16進法表示に変換

Dim description As String * SHA1_LENGTH_AS_STRING

Dim i&

For i = 0 To SHA1_LENGTH - 1

Mid(description, i * 2 + 1) = Right("0" & Hex(hashValue(i)), 2)

Next i

File2SHA1 = description

Exit Function

NoSuchFile:

MsgBox "そんなファイルないよ。"

End Function

==================================================

'★ファイルに使えるかどうかわからないプログラム

Option Explicit

Sub test()

Debug.Print UCase(HASH_SHA1("D:\1\123.accdb"))

Call CreateSHA1HashFile("D:\1\123.accdb")

End Sub

Public Function HASH_SHA256(str As String) As String

Dim sha256m As Object

Dim utf8 As Object

Dim bytes() As Byte

Dim hash() As Byte

Dim i As Integer

Dim res As String

Set utf8 = CreateObject("System.Text.UTF8Encoding")

bytes = utf8.GetBytes_4(str)

Set sha256m = CreateObject("System.Security.Cryptography.SHA256Managed")

hash = sha256m.ComputeHash_2((bytes))

For i = LBound(hash) To UBound(hash)

res = res & LCase(Right("0" & Hex(hash(i)), 2))

Next i

HASH_SHA256 = LCase(res)

End Function

Public Function HASH_SHA1(str As String) As String

Dim sha1m As Object

Dim utf8 As Object

Dim bytes() As Byte

Dim hash() As Byte

Dim i As Integer

Dim res As String

Set utf8 = CreateObject("System.Text.UTF8Encoding")

bytes = utf8.GetBytes_4(str)

Set sha1m = CreateObject("System.Security.Cryptography.SHA1Managed")

hash = sha1m.ComputeHash_2((bytes))

For i = LBound(hash) To UBound(hash)

res = res & LCase(Right("0" & Hex(hash(i)), 2))

Next i

HASH_SHA1 = LCase(res)

End Function

==================================================

●コマンドもAPIも.NetFramework3.5も、「どれも使わない」場合の、DOSコマンドでテキストファイルにハッシュをゲットするプログラム

これは、コマンドもAPIも.NetFramework3.5も、「どれも使わない」場合のものです。
特にWindows2000SP4Proなどでどうしても３つの方法が使えない場合、
（＝例えば社内規約によってとか、Windows2000SP4Pro自体も無いWin1000無印、とか、
　XPであっても、２つのファイルが入手できなかった場合、とか。）
に使う機会があるかもしれません。

'
'
Sub HashCalcTest01()

    Dim s_SrcFoldPath As String
    Dim s_SrcFileNm As String
    Dim s_Cmd01 As String
    Dim s_ResultTxtFullPath As String
       
    
    Let s_SrcFoldPath = "D:\1\"
    Let s_SrcFileNm = "rktools.exe"
'    Let s_SrcFileNm = "aaa.txt"
    '↑ハッシュ計算したいファイルのパスの設定


    'Print GetFileHashSha1("D:\1\rktools.exe")
    '3F3878FFB2C642E752D811DC05169BFCC2AA97B5
    '
    'Print GetFileHashSha1("D:\1\aaa.txt")
    '7E240DE74FB1ED08FA08D38063F6A6A91462A815


    Let s_ResultTxtFullPath = "D:\1\res.txt"
    '↑コマンド実行結果を書き込むファイルのフルパス
    ' 実行するたびに内容は上書きされる。
    
    
'    s_Cmd01 = "cmd /C DEL """ & s_FoldPath & "\222.txt"" > D:\1\res.txt /s"
'    s_Cmd01 = "cmd /C dir """ & s_FoldPath & """ > D:\1\res.txt /s"
    
    Let s_Cmd01 = "cmd /C certutil -hashfile """ & s_SrcFoldPath & s_SrcFileNm & """ > " & s_ResultTxtFullPath
    '↑ハッシュ計算のコマンドの生成
    
    Call Shell(s_Cmd01, 2)
    '↑ハッシュ計算の実行


    Application.Wait (Now + TimeValue("0:00:2"))
    '↑数秒待たないと、結果の上書きが追い付かないので、待つ。

    'テキストファイルを一括読み込みする
    'https://vbanobuhinko.com/%E3%83%86%E3%82%AD%E3%82%B9%E3%83%88%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E4%B8%80%E6%8B%AC%E8%AA%AD%E3%81%BF%E8%BE%BC%E3%81%BF%E3%81%99%E3%82%8B/
    Dim bhFSO As Object, bhFSOT As Object
    Set bhFSO = CreateObject("Scripting.FileSystemObject")
    '指定テキストファイルを開く
    Set bhFSOT = bhFSO.OpenTextFile(s_ResultTxtFullPath)
    
    '開いたテキストを1つのデータに一括読み込み
    Dim bhTxt As String
    bhTxt = bhFSOT.ReadAll
        
    Debug.Print bhTxt
    
    'FSOの解放
    Set bhFSOT = Nothing
    Set bhFSO = Nothing


End Sub



'
'

Sub HashCalcTest01()

Dim s_SrcFoldPath As String

Dim s_SrcFileNm As String

Dim s_Cmd01 As String

Dim s_ResultTxtFullPath As String

Let s_SrcFoldPath = "D:\1\"

Let s_SrcFileNm = "rktools.exe"

' Let s_SrcFileNm = "aaa.txt"

'↑ハッシュ計算したいファイルのパスの設定

'Print GetFileHashSha1("D:\1\rktools.exe")

'3F3878FFB2C642E752D811DC05169BFCC2AA97B5

'Print GetFileHashSha1("D:\1\aaa.txt")

'7E240DE74FB1ED08FA08D38063F6A6A91462A815

Let s_ResultTxtFullPath = "D:\1\res.txt"

'↑コマンド実行結果を書き込むファイルのフルパス

' 実行するたびに内容は上書きされる。

' s_Cmd01 = "cmd /C DEL """ & s_FoldPath & "\222.txt"" > D:\1\res.txt /s"

' s_Cmd01 = "cmd /C dir """ & s_FoldPath & """ > D:\1\res.txt /s"

Let s_Cmd01 = "cmd /C certutil -hashfile """ & s_SrcFoldPath & s_SrcFileNm & """ > " & s_ResultTxtFullPath

'↑ハッシュ計算のコマンドの生成

Call Shell(s_Cmd01, 2)

'↑ハッシュ計算の実行

Application.Wait (Now + TimeValue("0:00:2"))

'↑数秒待たないと、結果の上書きが追い付かないので、待つ。

'テキストファイルを一括読み込みする

'https://vbanobuhinko.com/%E3%83%86%E3%82%AD%E3%82%B9%E3%83%88%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E4%B8%80%E6%8B%AC%E8%AA%AD%E3%81%BF%E8%BE%BC%E3%81%BF%E3%81%99%E3%82%8B/

Dim bhFSO As Object, bhFSOT As Object

Set bhFSO = CreateObject("Scripting.FileSystemObject")

'指定テキストファイルを開く

Set bhFSOT = bhFSO.OpenTextFile(s_ResultTxtFullPath)

'開いたテキストを1つのデータに一括読み込み

Dim bhTxt As String

bhTxt = bhFSOT.ReadAll

Debug.Print bhTxt

'FSOの解放

Set bhFSOT = Nothing

Set bhFSO = Nothing

End Sub

●XP用の、コマンドでSHA1ハッシュをゲットするコード
（※コマンドプロンプトでのハッシュ値の割り出しの実行結果をVBA側に受け取る方式）
（※受け取り先が「配列」ではなく、普通の変数の方法）

（※コマンドを実行したあと、その結果の「数行」からハッシュ値だけを抽出
　　するコードも一緒になっています。SHA256以上も計算できます。）
（※一番上のコードのように、コマンド実行結果を配列では受け取りません。
　　結果の中身をループしてハッシュ値の部分を探し、それだけを
　　抜き出しています。多分、一番簡単な方法です。）

ただ、XPでは、通常はすぐには使えません。
しかし、
「Windows Server 2003 Service Pack 2 管理ツールパック (x86 エディション用)」
https://www.microsoft.com/ja-jp/download/details.aspx?id=6315
をダウンロード、インストールすると、
動くようになります。

ただその際、すべてのPCにそれをインストールしなくてもOKです。
どれか１つのPCにインストールし、その完了後に、最低限必要なファイルを
２つ抜き出して、他のマシンには、それをコピペすればOKです。
（「c:\windows\system32」に。）

その２つのファイルは、
「c:\windows\system32」の、「certutil.exe」と「certadm.dll」です。

このプログラム自体はDOS窓がちらついてしまいますが、ハッシュを取得する部分を消すかコメントアウトして、１つ上のプログラムとかけあわせると、DOS窓がちらつかないようにさせることができると思います。（その場合は、最低、Waitで２秒ほど待たないといけませんが）

'
'
Public Function GetFileHashSha1(s_FilePath As String) As String

    Dim o_WSH As Object
    Dim o_wshExec As Object
    Dim s_Cmd As String
    Dim s_Output As String
    Dim s_OutptStr01 As String
    Dim s_OutptStr02 As String
    
    Dim i_vbcrlfPosi01 As Integer
    Dim i_Cnt01 As Integer
    Dim i_RightLen As Integer
    
    
    If Dir(s_FilePath) <> "" Then
        'ファイルが存在する場合、こっちが実行される。
'        Debug.Print s_FilePath & "は存在します。"
    Else
        'ファイルが存在しない場合、こっちが実行される。
'        Debug.Print s_FilePath & "は存在しません。"
        Let GetFileHashSha1 = "ファイル無し"
        Exit Function
    End If
    Call Shell("certutil -hashfile ""d:\1\rktools.exe"" > d:\1\hash01.txt""", 1)

    
    Set o_WSH = CreateObject("WScript.Shell")
    s_Cmd = "certutil -hashfile " & _
            """" & s_FilePath & """"
    
    
    Set o_wshExec = o_WSH.Exec("%ComSpec% /c " & s_Cmd)
    '↑コマンドの実行（ハッシュ計算の開始）

    Do While o_wshExec.Status = 0
        DoEvents
    Loop
    '計算が終わるまで待つ。

    s_Output = o_wshExec.stdOut.ReadAll
'    Stop
    '↑コマンドの実行結果（XPやWin2000の場合は3行。Win10などの場合は4行）を、
    '  変数に全行分を受け取る。
    

    i_vbcrlfPosi01 = 0
'    Stop
    For i_Cnt01 = 1 To 2
        i_vbcrlfPosi01 = InStr(i_vbcrlfPosi01 + 1, s_Output, vbCrLf, vbBinaryCompare)
    Next i_Cnt01
    '↑受け取った結果をループして、ハッシュ値をゲットする。
    ' XPやWin2000SP4Proの場合は、結果が「３行」なので、
    ' ループは「 1 To 2」でOK。
'    Stop
    
    Let i_RightLen = Len(s_Output) - i_vbcrlfPosi01

    Let s_OutptStr01 = Right(s_Output, i_RightLen)

    Let i_vbcrlfPosi01 = 0
    Let i_vbcrlfPosi01 = InStr(1, s_OutptStr01, vbCrLf, vbBinaryCompare)
    
    Let s_OutptStr02 = Left(s_OutptStr01, i_vbcrlfPosi01)
    Let s_OutptStr02 = Replace(s_OutptStr02, " ", "", , , vbBinaryCompare)
    Let s_OutptStr02 = Replace(s_OutptStr02, vbLf, "", , , vbBinaryCompare)
    Let s_OutptStr02 = Replace(s_OutptStr02, vbCr, "", , , vbBinaryCompare)
    Let s_OutptStr02 = Replace(s_OutptStr02, vbCrLf, "", , , vbBinaryCompare)
    Let s_OutptStr02 = UCase(s_OutptStr02)

'    Debug.Print Len(s_OutptStr02)
    GetFileHashSha1 = s_OutptStr02
    
    Set o_wshExec = Nothing
    Set o_WSH = Nothing


End Function

'
'

Public Function GetFileHashSha1(s_FilePath As String) As String

Dim o_WSH As Object

Dim o_wshExec As Object

Dim s_Cmd As String

Dim s_Output As String

Dim s_OutptStr01 As String

Dim s_OutptStr02 As String

Dim i_vbcrlfPosi01 As Integer

Dim i_Cnt01 As Integer

Dim i_RightLen As Integer

If Dir(s_FilePath) <> "" Then

'ファイルが存在する場合、こっちが実行される。

' Debug.Print s_FilePath & "は存在します。"

Else

'ファイルが存在しない場合、こっちが実行される。

' Debug.Print s_FilePath & "は存在しません。"

Let GetFileHashSha1 = "ファイル無し"

Exit Function

End If

Call Shell("certutil -hashfile ""d:\1\rktools.exe"" > d:\1\hash01.txt""", 1)

Set o_WSH = CreateObject("WScript.Shell")

s_Cmd = "certutil -hashfile " & _

"""" & s_FilePath & """"

Set o_wshExec = o_WSH.Exec("%ComSpec% /c " & s_Cmd)

'↑コマンドの実行（ハッシュ計算の開始）

Do While o_wshExec.Status = 0

DoEvents

Loop

'計算が終わるまで待つ。

s_Output = o_wshExec.stdOut.ReadAll

' Stop

'↑コマンドの実行結果（XPやWin2000の場合は3行。Win10などの場合は4行）を、

' 変数に全行分を受け取る。

i_vbcrlfPosi01 = 0

' Stop

For i_Cnt01 = 1 To 2

i_vbcrlfPosi01 = InStr(i_vbcrlfPosi01 + 1, s_Output, vbCrLf, vbBinaryCompare)

Next i_Cnt01

'↑受け取った結果をループして、ハッシュ値をゲットする。

' XPやWin2000SP4Proの場合は、結果が「３行」なので、

' ループは「 1 To 2」でOK。

' Stop

Let i_RightLen = Len(s_Output) - i_vbcrlfPosi01

Let s_OutptStr01 = Right(s_Output, i_RightLen)

Let i_vbcrlfPosi01 = 0

Let i_vbcrlfPosi01 = InStr(1, s_OutptStr01, vbCrLf, vbBinaryCompare)

Let s_OutptStr02 = Left(s_OutptStr01, i_vbcrlfPosi01)

Let s_OutptStr02 = Replace(s_OutptStr02, " ", "", , , vbBinaryCompare)

Let s_OutptStr02 = Replace(s_OutptStr02, vbLf, "", , , vbBinaryCompare)

Let s_OutptStr02 = Replace(s_OutptStr02, vbCr, "", , , vbBinaryCompare)

Let s_OutptStr02 = Replace(s_OutptStr02, vbCrLf, "", , , vbBinaryCompare)

Let s_OutptStr02 = UCase(s_OutptStr02)

' Debug.Print Len(s_OutptStr02)

GetFileHashSha1 = s_OutptStr02

Set o_wshExec = Nothing

Set o_WSH = Nothing

End Function

●Windows2000（SP4？Pro版）でのコマンド利用でのハッシュ計算。（Certutil.exe利用）
（※「コマンドプロンプトでのハッシュ値割り出しの実行結果をVBA側に受け取る方式」）

WindowsXPはCertutil.exeが無かったのですが、Windows2000SP4ProやServerには、
あらかじめ、Certutil.exeが入っているようです。
ただ、格納場所が「C:\WINNT\system32\dllcache」でPATHが通っていません。
なので、下記コードの「PATH_Add01()」プロシージャにて、
「C:\WINNT\system32\dllcache」にパスを通します。

ただ、まあそこは手作業でももちろんOKです。

それが完了したら、PC再起動。

基本、
①「PATH_Add01()」関数などでPATHを通してPCを再起動し、
②コマンドプロンプトで「certutil /?」が正常にヘルプ表示されるかのチェックが必要です。

なお、「cert・・・」関連のファイルのうち、
C:\WINNT\system32\と
C:\WINNT\system32\dllcacheの両方に存在して、
コマンドプロンプト画面のテストで、「序数が・・・」のエラーになるときは、
C:\WINNT\system32\dllcacheにPATHを通したあとは、
C:\WINNT\system32\側の同名のファイルをリネームすると、
エラーが出なくなることがあります。
どのファイルをリネームするかは、出てきたエラーにファイル名が出るので、
そのファイルをリネームすればOKです。
（必ずしも常に１００％うまくいくとは限りませんが、今のところ、うまくいってます。）

'
'
Sub PATH_Add01()

    Dim wshShell As Object       ' 変数宣言
    Dim wshUserEnv  As Object
     
    Set wshShell = CreateObject("WScript.Shell")
    ' ユーザー環境変数の取得（システム環境変数の場合は System）
    Set wshUserEnv = wshShell.Environment("System")
    'PATHは「"System"」でよさそう。
    'https://vbabeginner.net/add-and-edit-environment-variables/　参照
     
    ' ユーザー環境変数 TESTUSERENV を設定する
    wshUserEnv.Item("PATH") = Environ("PATH") & "C:\WINNT\system32\dllcache;"
     
    ' 環境変数を削除する場合はコメントアウト
    'wshUserEnv.Remove ("PATH")
     
    Set wshUserEnv = Nothing
    Set wshShell = Nothing
End Sub

'上記コードで「C:\WINNT\system32\dllcache」にパスを通して、PC再起動。

'なお、「cert・・・」のファイルで、
'C:\WINNT\system32\と
'C:\WINNT\system32\dllcacheの両方に存在して、
'コマンドプロンプト画面のテストで、「序数が・・・」のエラーになるときは、
'C:\WINNT\system32\dllcacheにPATHを通したあとは、
'C:\WINNT\system32\側のファイルをリネームすると、エラーが出なくなることがあります。



'=====================================

Public Function GetFileHashSha1ForWin2000(s_FilePath As String) As String
 
'事前に、
'①「PATH_Add01()」関数などでPATHを通してPCを再起動し、
'②コマンドプロンプトで「certutil /?」が正常にヘルプ表示されるかのチェックが必要です。

    Dim o_WSH As Object
    Dim o_wshExec As Object
    Dim s_Cmd As String
    Dim s_Output As String
    Dim s_OutptStr01 As String
    Dim s_OutptStr02 As String
    
    Dim i_vbcrlfPosi01 As Integer
    Dim i_Cnt01 As Integer
    Dim i_RightLen As Integer
    
    
    If Dir(s_FilePath) <> "" Then
        'ファイルが存在する場合、こっちが実行される。
'        Debug.Print s_FilePath & "は存在します。"
    Else
        'ファイルが存在しない場合、こっちが実行される。
'        Debug.Print s_FilePath & "は存在しません。"
        Let GetFileHashSha1 = "ファイル無し"
        Exit Function
    End If
    Call Shell("certutil -hashfile ""d:\1\rktools.exe"" > d:\1\hash01.txt""", 1)
 
    
    Set o_WSH = CreateObject("WScript.Shell")
    Let s_Cmd = "certutil -hashfile " & _
                  """" & s_FilePath & """"
    
    
    Set o_wshExec = o_WSH.Exec("%ComSpec% /c " & s_Cmd)
 
    Do While o_wshExec.Status = 0
        DoEvents
    Loop
 
    Let s_Output = o_wshExec.stdOut.ReadAll
'    Stop
    
 
 
'    Let i_vbcrlfPosi01 = 0
'    Stop
'    For i_Cnt01 = 1 To 1
        Let i_vbcrlfPosi01 = InStr(i_vbcrlfPosi01 + 1, s_Output, vbCrLf, vbBinaryCompare)
'    Next i_Cnt01
     '↑XPの場合は４行あるので２回ループしたほうがいいけど、
     '　Win2000の場合は３行しかないのでループの必要がない。
     '　また、「XPと2000の両方で共通」に使えるようにしたいなら、
     '　後ろからやったほうが、後ろから２行目がハッシュ値なので、
     '　そのほうがいいかも。
    
'    Stop
    
    Let i_RightLen = Len(s_Output) - i_vbcrlfPosi01
 
    Let s_OutptStr01 = Right(s_Output, i_RightLen)
 
    Let i_vbcrlfPosi01 = 0
    Let i_vbcrlfPosi01 = InStr(1, s_OutptStr01, vbCrLf, vbBinaryCompare)
    
    Let s_OutptStr02 = Left(s_OutptStr01, i_vbcrlfPosi01)
    Let s_OutptStr02 = Replace(s_OutptStr02, " ", "", , , vbBinaryCompare)
    Let s_OutptStr02 = Replace(s_OutptStr02, vbLf, "", , , vbBinaryCompare)
    Let s_OutptStr02 = Replace(s_OutptStr02, vbCr, "", , , vbBinaryCompare)
    Let s_OutptStr02 = Replace(s_OutptStr02, vbCrLf, "", , , vbBinaryCompare)
    Let s_OutptStr02 = UCase(s_OutptStr02)
 
'    Debug.Print Len(s_OutptStr02)
    Let GetFileHashSha1 = s_OutptStr02
    
    Set o_wshExec = Nothing
    Set o_WSH = Nothing
 
 
End Function


'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

Sub PATH_Add01()

Dim wshShell As Object ' 変数宣言

Dim wshUserEnv As Object

Set wshShell = CreateObject("WScript.Shell")

' ユーザー環境変数の取得（システム環境変数の場合は System）

Set wshUserEnv = wshShell.Environment("System")

'PATHは「"System"」でよさそう。

'https://vbabeginner.net/add-and-edit-environment-variables/　参照

' ユーザー環境変数 TESTUSERENV を設定する

wshUserEnv.Item("PATH") = Environ("PATH") & "C:\WINNT\system32\dllcache;"

' 環境変数を削除する場合はコメントアウト

'wshUserEnv.Remove ("PATH")

Set wshUserEnv = Nothing

Set wshShell = Nothing

End Sub

'上記コードで「C:\WINNT\system32\dllcache」にパスを通して、PC再起動。

'なお、「cert・・・」のファイルで、

'C:\WINNT\system32\と

'C:\WINNT\system32\dllcacheの両方に存在して、

'コマンドプロンプト画面のテストで、「序数が・・・」のエラーになるときは、

'C:\WINNT\system32\dllcacheにPATHを通したあとは、

'C:\WINNT\system32\側のファイルをリネームすると、エラーが出なくなることがあります。

'=====================================

Public Function GetFileHashSha1ForWin2000(s_FilePath As String) As String

'事前に、

'①「PATH_Add01()」関数などでPATHを通してPCを再起動し、

'②コマンドプロンプトで「certutil /?」が正常にヘルプ表示されるかのチェックが必要です。

Dim o_WSH As Object

Dim o_wshExec As Object

Dim s_Cmd As String

Dim s_Output As String

Dim s_OutptStr01 As String

Dim s_OutptStr02 As String

Dim i_vbcrlfPosi01 As Integer

Dim i_Cnt01 As Integer

Dim i_RightLen As Integer

If Dir(s_FilePath) <> "" Then

'ファイルが存在する場合、こっちが実行される。

' Debug.Print s_FilePath & "は存在します。"

Else

'ファイルが存在しない場合、こっちが実行される。

' Debug.Print s_FilePath & "は存在しません。"

Let GetFileHashSha1 = "ファイル無し"

Exit Function

End If

Call Shell("certutil -hashfile ""d:\1\rktools.exe"" > d:\1\hash01.txt""", 1)

Set o_WSH = CreateObject("WScript.Shell")

Let s_Cmd = "certutil -hashfile " & _

"""" & s_FilePath & """"

Set o_wshExec = o_WSH.Exec("%ComSpec% /c " & s_Cmd)

Do While o_wshExec.Status = 0

DoEvents

Loop

Let s_Output = o_wshExec.stdOut.ReadAll

' Stop

' Let i_vbcrlfPosi01 = 0

' Stop

' For i_Cnt01 = 1 To 1

Let i_vbcrlfPosi01 = InStr(i_vbcrlfPosi01 + 1, s_Output, vbCrLf, vbBinaryCompare)

' Next i_Cnt01

'↑XPの場合は４行あるので２回ループしたほうがいいけど、

'　Win2000の場合は３行しかないのでループの必要がない。

'　また、「XPと2000の両方で共通」に使えるようにしたいなら、

'　後ろからやったほうが、後ろから２行目がハッシュ値なので、

'　そのほうがいいかも。

' Stop

Let i_RightLen = Len(s_Output) - i_vbcrlfPosi01

Let s_OutptStr01 = Right(s_Output, i_RightLen)

Let i_vbcrlfPosi01 = 0

Let i_vbcrlfPosi01 = InStr(1, s_OutptStr01, vbCrLf, vbBinaryCompare)

Let s_OutptStr02 = Left(s_OutptStr01, i_vbcrlfPosi01)

Let s_OutptStr02 = Replace(s_OutptStr02, " ", "", , , vbBinaryCompare)

Let s_OutptStr02 = Replace(s_OutptStr02, vbLf, "", , , vbBinaryCompare)

Let s_OutptStr02 = Replace(s_OutptStr02, vbCr, "", , , vbBinaryCompare)

Let s_OutptStr02 = Replace(s_OutptStr02, vbCrLf, "", , , vbBinaryCompare)

Let s_OutptStr02 = UCase(s_OutptStr02)

' Debug.Print Len(s_OutptStr02)

Let GetFileHashSha1 = s_OutptStr02

Set o_wshExec = Nothing

Set o_WSH = Nothing

End Function

投稿タグ: AccessVBA, Accessの独学, Access操作の基礎, ExcelVBA, Excelの独学, タイムスタンプ替わり, パソコンでの自動化, マクロ, 独学, 自動化, 電帳法

MENU

関連記事

最近の投稿

カテゴリー

MENU

★ExcelVBA ～ 【電子帳簿保存法・タイムスタンプがらみ】ファイルのハッシュ値をゲットする関数

関連記事

最近の投稿

カテゴリー

タグ

★ExcelVBA ～【電子帳簿保存法・タイムスタンプがらみ】ファイルのハッシュ値をゲットする関数