【VBA】暗号化API を使って、ファイルのハッシュ値（SHA-1、SHA-256、SHA-512、MD5）を求めてみた。

ダウンロードしたファイルの検証や、ファイルの改竄がないかの検証などに
MD5や、SHA-256などによるハッシュ値が使われる事があります。

例えば、下の図は、CrystalDiskInfoのダウンロードサイト に記載されているハッシュ値部分をキャプチャしたものです。

今回、VBA で、ファイルをByte 配列に読み込んで、
MD5、SHA-1、SHA-256、SHA-512によるハッシュ値を求めてみました。
（MS が非推奨と言っているAPIを使っています。）

以下、非推奨とうたっている部分の抜粋と翻訳

This API is deprecated. New and existing software should start using Cryptography Next Generation APIs. Microsoft may remove this API in future releases.

この API は非推奨です。新規および既存のソフトウェアは、Cryptography Next Generation APIs の使用を開始する必要があります。Microsoft は将来のリリースでこの API を削除する可能性があります。

暗号学的ハッシュ関数

暗号学的ハッシュ関数は、ハッシュ関数のうち、暗号など情報セキュリティの用途に適する暗号数理的性質をもつもの。任意の長さの入力を（通常は）固定長の出力に変換する

https://ja.wikipedia.org/wiki/%E6%9A%97%E5%8F%B7%E5%AD%A6%E7%9A%84%E3%83%8F%E3%83%83%E3%82%B7%E3%83%A5%E9%96%A2%E6%95%B0

アルゴリズムが異なるハッシュ関数が何種類かあります。

SHA-1

Secure Hash Algorithmシリーズの暗号学的ハッシュ関数で、SHAの最初のバージョンであるSHA-0の弱点を修正したものだそうです。
Wikipediaによると、「シャーワン」と読むらしいです。
ja.wikipedia.org

SHA-2

前身のSHA-1から多くの改良が加えられており、6つのバリエーションが存在し、
SHA-256、SHA-512は、そのバリエーションのひとつです。
ja.wikipedia.org

MD5

MD4が前身であり、安全性を向上させたものとされている。
ただし、

2018年現在において、弱点が発見されていることを筆頭に暗号学的ハッシュ関数として必要な強度は既に残っていないので、強度が必要な場合には使ってはいけない。

https://ja.wikipedia.org/wiki/MD5#%E7%94%A8%E9%80%94

ja.wikipedia.org

環境

OS：Windows 10 Home 64bit
Excel：Microsoft 365 Personal 64bit

コード

ライセンス

MITライセンスを適用するものとします。
ご自由にお使いください。

Copyright (c) 2020 Z1000R_LR

This software is released under the MIT License.
http://opensource.org/licenses/mit-license.php

API 宣言等

Public Enum ALG_ID
    CALG_MD5 = &H8003&
    CALG_SHA1 = &H8004&
    CALG_SHA_256 = &H800C&
    CALG_SHA_512 = &H800E&
End Enum

Private Declare PtrSafe Function CryptAcquireContext Lib "Advapi32.dll" Alias "CryptAcquireContextA" ( _
    ByRef phProv As LongPtr, _
    ByVal szContainer As String, _
    ByVal szProvider As String, _
    ByVal dwProvType As Long, _
    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 CryptHashData Lib "Advapi32.dll" ( _
    ByVal hHash As LongPtr, _
    ByRef pbData As Any, _
    ByVal dwDataLen As Long, _
    ByVal dwFlags As Long) As Long

Private Declare PtrSafe Function CryptGetHashParam Lib "Advapi32.dll" ( _
    ByVal hHash As LongPtr, _
    ByVal dwParam As Long, _
    ByRef pbData As Any, _
    ByRef pdwDataLen As Long, _
    ByVal dwFlags As Long) As Long

Private Declare PtrSafe Function CryptDestroyHash Lib "Advapi32.dll" ( _
    ByVal hHash As LongPtr) As Long

Private Declare PtrSafe Function CryptReleaseContext Lib "Advapi32.dll" ( _
    ByVal hProv As LongPtr, _
    ByVal dwFlags As Long) As Long

Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long

Private Const PROV_RSA_AES          As Long = &H18&
Private Const CRYPT_VERIFYCONTEXT   As Long = &HF0000000
Private Const HP_HASHVAL            As Long = &H2&

Private Const ERROR_FILE_NOT_FOUND  As Long = &H2&
Private Const ERROR_INVALID_DATA    As Long = &HD&

ハッシュ値計算

'パラメータ
'   byContentArry(IN)   :ハッシュを計算するファイル（Byte配列）
'   algid(IN)           :取得するハッシュの種類
'   sHash(OUT)          :計算したハッシュ値
'復帰値
'   0                   :成功
'   0以外               :失敗（GetLastErrorによるエラーコード）
Public Function getHash(ByRef byContentArry() As Byte, ByVal algid As ALG_ID, ByRef sHash As String) As Long

    Dim byHash()    As Byte
    Dim hProv       As LongPtr
    Dim hHash       As LongPtr
    Dim lHashBytes  As Long
    Dim lResult     As Long
    Dim lContentBytes   As Long
    Dim i           As Long

    sHash = ""

    'ハッシュ長設定
    Select Case algid
    Case ALG_ID.CALG_MD5
        lHashBytes = 16
    Case ALG_ID.CALG_SHA1
        lHashBytes = 20
    Case ALG_ID.CALG_SHA_256
        lHashBytes = 32
    Case ALG_ID.CALG_SHA_512
        lHashBytes = 64
    Case Else
        Err.Raise ERROR_INVALID_DATA, "getHash", "Invalid ALG_ID.[ 0x" & Right$("0000000" & Hex(algid), 8) & " ]"
    End Select

    'ハッシュ格納用
    ReDim byHash(lHashBytes - 1)

    Do
        '暗号化サービスプロバイダ内の特定のキーコンテナのハンドルを取得
        lResult = CryptAcquireContext(hProv, vbNullString, vbNullString, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)
        If lResult = 0 Then
            lResult = GetLastError
            Exit Do
        End If

        '暗号化サービスプロバイダのハッシュオブジェクトのハンドル作成
        lResult = CryptCreateHash(hProv, algid, 0, 0, hHash)
        If lResult = 0 Then
            lResult = GetLastError
            Exit Do
        End If

        'ハッシュオブジェクトにデータを追加
        lContentBytes = UBound(byContentArry) - LBound(byContentArry) + 1
        lResult = CryptHashData(hHash, byContentArry(0), lContentBytes, 0)
        If lResult = 0 Then
            lResult = GetLastError
            Exit Do
        End If

        'ハッシュ値取得
        lResult = CryptGetHashParam(hHash, HP_HASHVAL, byHash(0), lHashBytes, 0)
        If lResult = 0 Then
            lResult = GetLastError
            Exit Do
        End If

        'Byte配列から16進文字列化
        sHash = String$(lHashBytes * 2, "0")
        For i = 0 To lHashBytes - 1
            Mid$(sHash, i * 2 + 1, 2) = Right$("0" & Hex(byHash(i)), 2)
        Next i
    Loop While False

    If hHash <> 0 Then
        'hHashで参照されるハッシュオブジェクト破棄
        Call CryptDestroyHash(hHash)
    End If

    If hProv <> 0 Then
        '暗号サービスプロバイダと鍵コンテナのハンドル解放
        Call CryptReleaseContext(hProv, 0)
    End If

End Function

ファイル読み込み

Public Function getFileContent(ByVal sTargetPath As String, ByRef byContentArry() As Byte) As Long

    Dim iFileNo As Integer
    Dim lBytes  As Long

    On Error GoTo ERR_FILE_OPEN_FAIL

    'ファイルパスチェック
    If Len(sTargetPath) = 0 Then
        Err.Raise ERROR_INVALID_DATA, "getFileContent", "Path is zero length."
    ElseIf Dir(sTargetPath) = "" Then
        Err.Raise ERROR_FILE_NOT_FOUND, "getFileContent", "File Not Found."
    ElseIf GetAttr(sTargetPath) = vbDirectory Then
        Err.Raise ERROR_INVALID_DATA, "getFileContent", "Path is directory."
    End If

    'ファイル読み込み
    iFileNo = FreeFile
    Open sTargetPath For Binary Access Read As iFileNo
    lBytes = LOF(iFileNo)
    ReDim byContentArry(lBytes - 1)
    Get iFileNo, 1, byContentArry
    Close iFileNo

    Exit Function

ERR_FILE_OPEN_FAIL:
    getFileContent = Err.Number

    Debug.Print "[0x" & Right$("0000000" & Hex(Err.Number), 8) & "] getFileContent :" & Err.Description

End Function

実行例

呼び出し

Public Sub getVBE7DllHash()

    Const TARGET_PATH   As String = "C:\Program Files\Microsoft Office\root\vfs\ProgramFilesCommonX64\Microsoft Shared\VBA\VBA7.1\VBE7.DLL"
    Dim byContentArry() As Byte
    Dim sHash   As String

    Call getFileContent(TARGET_PATH, byContentArry)
    Call getHash(byContentArry, CALG_MD5, sHash)
    Debug.Print "MD5    :" & sHash
    Call getHash(byContentArry, CALG_SHA1, sHash)
    Debug.Print "SHA1   :" & sHash
    Call getHash(byContentArry, CALG_SHA_256, sHash)
    Debug.Print "SHA-256:" & sHash
    Call getHash(byContentArry, CALG_SHA_512, sHash)
    Debug.Print "SHA-512:" & sHash

End Sub

実行結果

注）VBEThemeColorEditorで、色をカスタマイズしたVBE7.DLLのため、正規のVBE7.DLL のハッシュ値とは異なります。

【VBA】トライ木を使って、文字列Aにある文字列Bを数えてみた

トライ木とは

人に説明できるだけ理解していないので、Wikipediaより抜粋。

順序付き木の一種。あるノードの配下の全ノードは、自身に対応する文字列に共通するプレフィックス（接頭部）があり、ルート（根）には空の文字列が対応している。値は一般に全ノードに対応して存在するわけではなく、末端ノードや一部の中間ノードだけがキーに対応した値を格納している。2分探索木と異なり、各ノードに個々のキーが格納されるのではなく、木構造上のノードの位置とキーが対応している。

https://ja.wikipedia.org/wiki/%E3%83%88%E3%83%A9%E3%82%A4_(%E3%83%87%E3%83%BC%E3%82%BF%E6%A7%8B%E9%80%A0)

ja.wikipedia.org

コード

トライ木

クラスモジュール：CTrie

Option Explicit

Private Const BASE As Long = 65&

Public val  As Long
Private nxt_(25) As CTrie

Public Property Get nxt(ByVal index As Long) As CTrie

    Set nxt = nxt_(index)

End Property

Public Function createNxt(ByVal index As Long) As CTrie

    Set nxt_(index) = New CTrie

    Set createNxt = nxt_(index)

End Function

Public Sub instert(ByVal s As String)

    Dim cur As CTrie
    Dim i   As Long

    Set cur = Me

    For i = 1 To Len(s)
        If cur.nxt(Asc(Mid(s, i, 1)) - BASE) Is Nothing Then
            Call cur.createNxt(Asc(Mid(s, i, 1)) - BASE)
        End If

        Set cur = cur.nxt(Asc(Mid(s, i, 1)) - BASE)
    Next i
    cur.val = cur.val + 1
End Sub

Public Function exitsIn(ByVal s As String) As Boolean

    Dim cur As CTrie
    Dim ss As String
    Dim i   As Long

    For i = 1 To Len(s)
        Set cur = Me

        ss = Mid(s, i)

        Do While Len(ss) > 0 And (Not cur Is Nothing)
            Set cur = cur.nxt(Asc(Left(ss, 1)) - BASE)

            If Not cur Is Nothing Then
                If cur.val > 0 Then
                    exitsIn = True
                    Exit Function
                End If
            End If

            If Len(ss) < 2 Then
                Exit Do
            End If
            ss = Mid(ss, 2)
        Loop
    Next i

    exitsIn = False

End Function

Public Function count(ByVal s As String) As Long

    Dim cur     As CTrie
    Dim lCount  As Long
    Dim ss      As String
    Dim i       As Long

    For i = 1 To Len(s)
        Set cur = Me

        ss = Mid(s, i)

        Do While Len(ss) > 0 And (Not cur Is Nothing)
            Set cur = cur.nxt(Asc(Left(ss, 1)) - BASE)

            If Not cur Is Nothing Then
                lCount = lCount + cur.val
            End If

            If Len(ss) < 2 Then
                Exit Do
            End If
            ss = Mid(ss, 2)
        Loop
    Next i

    count = lCount

End Function

標準モジュール（クラスモジュールの呼び出し）

Sub fuga()

    Dim tr As CTrie
    Dim sPath As String
    Dim iFNo    As Integer
    Dim s As String
    Dim ss As String
    Dim cnt As Long
    Dim i   As Long

    Dim sw  As New CStopWatch
    Dim start As LongLong
    Dim stp As LongLong

    start = sw.GetValueOfTickCnt

    sPath = "C:\Datas\sample.txt"
    iFNo = FreeFile

    Open sPath For Input Access Read As iFNo

    Line Input #iFNo, s
    Line Input #iFNo, ss
    cnt = CLng(ss)

    Set tr = New CTrie
    For i = 0 To cnt - 1
        Line Input #iFNo, ss
        tr.instert ss
    Next i

    Close iFNo

    Debug.Print "Trie"
    Debug.Print "Result:" & tr.count(s)

    stp = sw.GetValueOfTickCnt
    Debug.Print "Time  :" & stp - start & " [msec]"

End Sub

InStr

Sub piyo()

    Dim sPath As String
    Dim iFNo    As Integer
    Dim s As String
    Dim ss As String
    Dim cnt As Long
    Dim c() As String
    Dim pos As Long
    Dim lResult As Long
    Dim i   As Long

    Dim sw  As New CStopWatch
    Dim start As LongLong
    Dim stp As LongLong

    start = sw.GetValueOfTickCnt

    sPath = "C:\Datas\sample.txt"
    iFNo = FreeFile

    Open sPath For Input Access Read As iFNo

    Line Input #iFNo, s
    Line Input #iFNo, ss
    cnt = CLng(ss)
    ReDim c(cnt - 1)

    For i = 0 To cnt - 1
        Line Input #iFNo, ss
        c(i) = ss
    Next i

    Close iFNo

    For i = 0 To cnt - 1
        pos = 1

        Do
            pos = InStr(pos, s, c(i))

            If pos > 0 Then
                lResult = lResult + 1

                pos = pos + 1
            End If
        Loop Until pos = 0
    Next i

    stp = sw.GetValueOfTickCnt

    Debug.Print "Instr"
    Debug.Print "Result:" & lResult
    Debug.Print "Time  :" & stp - start & " [msec]"

End Sub

Sub hoge()

    Dim i As Long

    For i = 1 To 10
        Call fuga
        Call piyo
    Next i

End Sub

結果

テストデータ

yukicoder の、No.430 文字列検索 のテストデータ より、challege02.txt を使用してみた。

文字数：50,000
検索対象文字：5,000個（ランダム文字列）

こんな感じ（一部のみ）

5000の上が、検索元となるデータ文字列
5000の下が、検索文字列

結果

hoge の実行結果、トライ木は、InStr の約２倍の時間がかかりました。
トライ木が、InStrの約３割程度の時間で処理できた。

個人的には、トライ木が速いというよりも、
InStr が、予想以上に速かったという感想。
コメントによるご指摘により、計測位置が間違っている事が判明したため、下記のデータを含めて修正しました。（2020/11/4 16:30）

	Trie木	InStr
1	547	250
2	547	265
3	547	281
4	562	265
5	516	281
6	500	281
7	500	265
8	532	266
9	484	265
10	500	266
平均 [msec]	523	268

ちなみに、C++で実装したら、6 msec でした。

【C++】Windowsをシャットダウン or サスペンド させる

スタートメニューを辿っていくのが面倒だったので、
実行ファイルを作って、デスクトップにショートカットを作ることにしました。

環境
Windows 10 Home 64bit
Visual Studio Community 2019

#include <Windows.h>
#include <iostream>

using namespace std;


BOOL EnablePrivileges(LPCTSTR lpcPrivilegeName, BOOL bEnable);

int main()
{
    int iResult{ 1 };
    wstring sResult;

    while (true)
    {
        //SE_SHUTDOWN_NAME(シャットダウン特権) を有効にする
        if (!EnablePrivileges(SE_SHUTDOWN_NAME, TRUE))
        {
            sResult = L"EnablePrivileges failed";

            break;
        }

        if (!InitiateSystemShutdownEx(nullptr, nullptr, 0, FALSE, FALSE, SHTDN_REASON_FLAG_USER_DEFINED))
        {
            sResult = L"InitiateSystemShutdownEx failed";

            break;
        }

        sResult = L"InitiateSystemShutdownEx succeeded !";

        iResult = 0;

        break;
    }

    wcout << sResult << endl;

    return iResult;
}

BOOL EnablePrivileges(LPCTSTR lpcPrivilegeName, BOOL isEnable)
{
    //プロセストークン取得
    HANDLE hToken;
    BOOL isSuccess = OpenProcessToken(GetCurrentProcess(),
        TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
        &hToken);

    if (!isSuccess)
    {
        return FALSE;
    }

    //特権に対応するLUID取得
    LUID luid;
    isSuccess = LookupPrivilegeValue(nullptr, lpcPrivilegeName, &luid);
    if (isSuccess)
    {
        //TOKEN_PRIVILEGES型のオブジェクトに、LUIDと特権の属性(有効にするか無効にするか)を指定
        TOKEN_PRIVILEGES tokenPrivileges;
        tokenPrivileges.PrivilegeCount = 1;
        tokenPrivileges.Privileges[0].Luid = luid;
        tokenPrivileges.Privileges[0].Attributes = isEnable ? SE_PRIVILEGE_ENABLED : 0;

        //特権を設定する
        isSuccess = AdjustTokenPrivileges(hToken,
            FALSE,
            &tokenPrivileges, 0, 0, 0);
    }

    CloseHandle(hToken);

    return isSuccess;
}

シャットダウンではなく、サスペンドさせたい場合には、
１．以下を追加

#include <powrprof.h>   //SetSuspendState

#pragma comment(lib, "PowrProf.lib")

２．以下を変更

        //if (!InitiateSystemShutdownExW(nullptr, nullptr, 0, FALSE, FALSE, SHTDN_REASON_FLAG_USER_DEFINED))
        if (!SetSuspendState(TRUE, FALSE, TRUE))

コメントは、適宜変更してください。

この実行ファイルでサスペンドさせると、復帰した時に、スタートメニューが表示されないので、スッキリしています。

【C++】フォルダ内のファイル一覧取得（エクスプローラー風ソート）

前置き

C++で、FindFirstFileEx を使って、ファイルを取得。
エクスプローラー風に、数字が綺麗に昇順になるようにソートする。
サブフォルダは、除外。

コード

#include <iostream>
#include <vector>
#include <algorithm>
#include <string>
#include <Windows.h>
#include <shlwapi.h>    //StrCmpLogicalW

#pragma comment(lib,"Shlwapi.lib")

using namespace std;

int main()
{
    //wcin の文字化け対策
    ios_base::sync_with_stdio(false);
    wcin.imbue(locale("japanese"));

    wcout << L"Input target Folder:";

    wstring sTargetFolder;
    getline(wcin, sTargetFolder);

    if (!sTargetFolder.size())
    {
        wcout << L"Not entered.\n";

        return 0;
    }

    //スペース等を含んだパスのような場合の前後のダブルクォーテーションを除去
    if ((sTargetFolder.substr(0, 1) == L"\"") &&
        (sTargetFolder.substr(sTargetFolder.size() - 1, 1) == L"\""))
        sTargetFolder = sTargetFolder.substr(1, sTargetFolder.size() - 2);

    //パスの末尾が "\" でない場合、"\" を付加
    if (sTargetFolder.substr(sTargetFolder.size() - 1) != L"\\")
        sTargetFolder += L"\\";

    //全ファイルを対象
    sTargetFolder += L"*";

    WIN32_FIND_DATA fd;
    HANDLE hFind = FindFirstFileExW(
        sTargetFolder.c_str(),
        FindExInfoBasic,
        &fd,
        FindExSearchNameMatch,
        nullptr,
        FIND_FIRST_EX_LARGE_FETCH);

    if (hFind == INVALID_HANDLE_VALUE)
    {
        wcout << L"Target not found.\n";

        return 0;
    }

    vector<wstring> vFiles;

    do
    {
        //フォルダは除外
        if (fd.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)
            continue;

        vFiles.push_back(fd.cFileName);
    } while (FindNextFileW(hFind, &fd));

    FindClose(hFind);

    //エクスプローラー風のソート
    sort(vFiles.begin(),
        vFiles.end(),
        [](const wstring& ws1, const wstring& ws2)
    {
        return StrCmpLogicalW(ws1.c_str(), ws2.c_str()) < 0;
    });

    for (const auto& v : vFiles)
        wcout << v << L"\n";

    return 0;
}

実行結果

検索対象ファイル

実行

通常のソートを使用した場合

sort(vFiles.begin(), vFiles.end());

気が向いたら、再帰して、サブフォルダも処理するやつを作るかもしれない・・・
（作りそうな気がする・・・）

参考

VBAで、FindFirstFile （Ex でないやつ）を使ったやつ
z1000s.hatenablog.com

上の記事ので紹介している記事の発展版。
VBAで、FindFirstFileEx を使ってやってるので、興味がある方はどうぞ。
www.excel-chunchun.com

sort を参考に（パクリとも言う）させていただきました。m(_ _)m
suzulang.com

【VBA】Twitter お題 「280バイトを超えない範囲で区切りのよいところで分割したい」を解いてみた

Twitter のお題、
280バイトを超えない範囲で区切りのよいところで分割したい
を解いてみました。

お題は、こちら

【エクセルお題】
ツイートの下書きをA1セルに入れています。
バイト数はLENB関数で分かりますが、単純に280バイトで区切ってしまうと文章が尻切れになってしまいます。
そこで280バイトを超えない範囲で区切りのよいところで分割したい。
→画像に続く pic.twitter.com/Noiy2yJMT1

— エクセルの神髄 (@yamaoka_ss) 2020年6月14日

処理の概要

1. 先頭から、280バイト切り出し（末尾の２バイト文字がバラバラにならないように）
2. 後ろから、区切り文字（"。" or LF）を検索
3. その位置まで、配列に格納
4. 先頭位置を、移動して、280バイト未満になるまで繰り返し
5. 280バイト未満の文字列が残っていれば、それも追加

ある程度の汎用性を持たせているので
正直なところ、効率は良くない方法ですw

専用の関数にして、効率よくする方法はいくつかあるけのだけれど、あえてやってません。

Option Explicit

Public Sub hoge()

    Const MAX_BYTES As Long = 280&

    Dim sResults()  As String
    Dim sSrc        As String
    Dim lElems      As Long
    Dim i           As Long

    sSrc = Sheet1.Range("A1").Value

    lElems = splitCustom(sSrc, MAX_BYTES, sResults)

    For i = 0 To lElems - 1
        Sheet1.Range("A2").Offset(i).Value = sResults(i)
    Next i

    Debug.Print "Done."

End Sub

Public Function splitCustom(ByVal sSrc As String, _
                            ByVal lMaxBytes As Long, _
                            ByRef sResultArray() As String) As Long

    Dim sTarget As String
    Dim sElem   As String
    Dim lDelimPos   As Long
    Dim lIndex      As Long
    Dim lOffset     As Long

    lIndex = 0
    ReDim sResultArray(lIndex)

    sTarget = sSrc
    Do Until LenByte(sTarget) < lMaxBytes
        sElem = LeftByte(sTarget, lMaxBytes)
        lDelimPos = getLastTargetPos(sElem)
        ReDim Preserve sResultArray(lIndex)

        If lDelimPos > 0 Then
            sResultArray(lIndex) = Left$(sElem, lDelimPos)
            lOffset = lDelimPos + 1
        Else
            sResultArray(lIndex) = sElem
            lOffset = Len(sElem) + 1
        End If

        lIndex = lIndex + 1
        sTarget = Mid$(sTarget, lOffset)
    Loop

    If Len(sTarget) > 0 Then
        ReDim Preserve sResultArray(lIndex)
        sResultArray(lIndex) = sTarget
        lIndex = lIndex + 1
    End If

    splitCustom = lIndex

End Function

Private Function getLastTargetPos(ByVal sSrc As String) As Long

    Dim sDelimiters(1)  As String
    Dim lDelimPos       As Long
    Dim lResult         As Long
    Dim i               As Long

    sDelimiters(0) = "。"
    sDelimiters(1) = vbLf

    lResult = -1

    For i = 0 To UBound(sDelimiters)
        lDelimPos = InStrRev(sSrc, sDelimiters(i))

        If lDelimPos > 0 Then
            If lDelimPos > lResult Then
                lResult = lDelimPos
            End If
        End If
    Next i

    getLastTargetPos = lResult

End Function

Private Function LenByte(ByVal sSrc As String) As Long

    Dim sConverted  As String

    sConverted = StrConv(sSrc, vbFromUnicode)

    LenByte = LenB(sConverted)

End Function

Private Function LeftByte(ByVal sSrc As String, ByVal lBytes As Long) As String

    Dim sConverted  As String
    Dim sResult     As String

    sConverted = StrConv(sSrc, vbFromUnicode)

    If LenB(sConverted) <= lBytes Then
        LeftByte = sSrc

        Exit Function
    End If

    sResult = StrConv(LeftB(sConverted, lBytes + 1), vbUnicode)

    LeftByte = Left(sResult, Len(sResult) - 1)

End Function

実行結果

2020/6/15 追記
正規表現を使用した処理も書いてみました。

Public Function splitCusom2(ByVal sSrc As String, _
                            ByVal lMaxBytes As Long, _
                            ByRef sResultArray() As String) As Long

    Dim re      As RegExp
    Dim mc      As MatchCollection
    Dim sTarget As String
    Dim sElem   As String
    Dim lIndex      As Long
    Dim lOffset     As Long

    Set re = New RegExp

    With re
        .Global = True
        .MultiLine = True
        '"."は、"。"にはマッチするが、改行にマッチしないので、途中に改行が含まれていてもマッチさせる
        .Pattern = "^(.|\n)+(。|\n)"
    End With

    lIndex = 0
    ReDim sResultArray(lIndex)

    sTarget = sSrc
    Do Until LenByte(sTarget) < lMaxBytes
        ReDim Preserve sResultArray(lIndex)

        sElem = LeftByte(sTarget, lMaxBytes)

        Set mc = re.Execute(sElem)
        If mc.Count > 0 Then
            sResultArray(lIndex) = mc.Item(0)
            lOffset = Len(sResultArray(lIndex)) + 1
        Else
            sResultArray(lIndex) = sElem
            lOffset = Len(sElem) + 1
        End If

        lIndex = lIndex + 1
        sTarget = Mid$(sTarget, lOffset)
    Loop

    If Len(sTarget) > 0 Then
        ReDim Preserve sResultArray(lIndex)
        sResultArray(lIndex) = sTarget
        lIndex = lIndex + 1
    End If

    splitCusom2 = lIndex

End Function

【VBA】組み合わせ数を求める

n個の要素から、r個を抜き出す組み合わせ数を求めてみた。

とりあえず、コードだけ。
解説は、時間とその気が出来たら、後日www

n = 99 なら、全ての r の組み合わせを出力できる。
n = 100 なら、47 <= r <=53 の時、オーバーフローする。

コード

Public Function nCr(ByVal n As Long, ByVal r As Long) As Variant

    Dim dicD        As Dictionary
    Dim dicM        As Dictionary
    '分母
    Dim lDenominatorMin As Long
    Dim lDenominatorMax As Long
    '分子
    Dim lMoleculeMin    As Long
    Dim lMoleculeMax    As Long
    Dim v           As Variant
    Dim vResult     As Variant
    Dim i           As Long

    Debug.Assert n >= r
    Debug.Assert r > 0

    Set dicD = New Dictionary
    Set dicM = New Dictionary

    If n - r >= r Then
        lDenominatorMax = n - r
    Else
        lDenominatorMax = r
    End If
    lDenominatorMin = 1

    lMoleculeMax = n
    lMoleculeMin = n - lDenominatorMax + 1

    '分母
    For i = lDenominatorMin To lDenominatorMax
        Call primeFactorization(i, dicD)
    Next i

    '分子
    For i = lMoleculeMin To lMoleculeMax
        Call primeFactorization(i, dicM)
    Next i

    '約分処理
    '分母要素から、分子要素を消し込む
    For Each v In dicD.Keys
        Debug.Assert dicD.Item(v) > 0
        Debug.Assert dicM.Exists(v)
        Debug.Assert dicM.Item(v) >= dicD.Item(v)

        If dicM.Item(v) > dicD.Item(v) Then
            dicM.Item(v) = dicM.Item(v) - dicD.Item(v)
        Else
            dicM.Remove v
        End If
    Next v

    '組み合わせ数のオーバーフロー対策として、Decimalを使用する
    vResult = CDec(1)

    For Each v In dicM.Keys
        vResult = vResult * (CDec(v) ^ dicM.Item(v))
    Next v

'    Debug.Print "Result:" & Format(vResult, "#,##0")

    nCr = vResult

End Function

'素因数分解
'例：
'lValue（素因数分解する値）に12を指定した場合、
' 12 = 2 ^2 * 3 ^1
'なので、
'dicPrimeFactorには、
'Key Item
' 2   2
' 3   1
'が格納されて返る
Private Sub primeFactorization(ByVal lValue As Long, ByRef dicPrimeFactor As Dictionary)

    Dim lPrimeFactor    As Long
    Dim lTargetValue    As Long
    Dim v               As Variant

    If dicPrimeFactor Is Nothing Then
        Set dicPrimeFactor = New Dictionary
    End If

    lTargetValue = lValue
    '素因数初期値
    lPrimeFactor = 2

    Do While lTargetValue >= lPrimeFactor * lPrimeFactor
        If (lTargetValue Mod lPrimeFactor) = 0 Then
            If dicPrimeFactor.Exists(lPrimeFactor) Then
                dicPrimeFactor.Item(lPrimeFactor) = dicPrimeFactor.Item(lPrimeFactor) + 1
            Else
                dicPrimeFactor.Add lPrimeFactor, 1
            End If

            lTargetValue = lTargetValue \ lPrimeFactor
        Else
            lPrimeFactor = lPrimeFactor + 1
        End If
    Loop

    '最後に残った物も、素因数なので、追加する
    'lPrimeFactor は、2から始めているので、Keyに1は存在しない。
    If dicPrimeFactor.Exists(lTargetValue) Then
        dicPrimeFactor.Item(lTargetValue) = dicPrimeFactor.Item(lTargetValue) + 1
    ElseIf lTargetValue <> 1 Then
        '1は、結果に影響を与えないので、無視する
        dicPrimeFactor.Add lTargetValue, 1
    End If

End Sub

実行例

for i=1 to 50:? i & ":" & nCr(99,i):next
1:99
2:4851
3:156849
4:3764376
5:71523144
6:1120529256
7:14887031544
8:171200862756
9:1731030945644
10:15579278510796
11:126050526132804
12:924370524973896
13:6186171974825304
14:38000770702498296
15:215337700647490344
16:1130522928399324306
17:5519611944537877494
18:25144898858450330806
19:107196674080761936594
20:428786696323047746376
21:1613054714739084379224
22:5719012170438571889976
23:19146258135816088501224
24:60629817430084280253876
25:181889452290252840761628
26:517685364210719623706172
27:1399667836569723427057428
28:3599145865465003098147672
29:8811701946483283447189128
30:20560637875127661376774632
31:45764000431735762419272568
32:97248500917438495140954207
33:197443926105102399225573693
34:383273503615787010261407757
35:711793649572175876199757263
36:1265410932572757113244012912
37:2154618614921181030658724688
38:3515430371713505892127392912
39:5498493658321124600506947888
40:8247740487481686900760421832
41:11868699725888281149874753368
42:16390109145274293016493707032
43:21726423750712434928840495368
44:27651812046361280818524266832
45:33796659167774898778196326128
46:39674339023040098565708730672
47:44739148260023940935799206928
48:48467410615025936013782474172
49:50445672272782096667406248628
50:50445672272782096667406248628

【C++】Twitter のお題 「魚の数を数えろ！」を正規表現を使って解いてみた

ゴールデンウィークに行われた、Twitter のお題
「魚の数を数えろ！」
「魚の数を数えろ！　蟹バージョン」
を今更ながら、C++で正規表現を使って解いてみた。

物足りない人向けに、ちょっと難易度を上げた
アレンジ問題を。

タラバガニ毛ガニタラバガニ毛ガニ越前蟹タラバガニ花咲蟹越前蟹越前蟹越前蟹ズワイガニズワイガニ越前蟹タラバガニズワイガニ

１．カニの種類は、何種類か？
２．それぞれのカニはいくつあるか？

を求めてください。

— 空腹おやじ (@Z1000R_LR) 2020年5月6日

複数のマッチがある場合の繰り返し処理がわからず、あちこち探してやっと完成。
結局、開始位置をイテレーターで、移動させ、マッチしなくなるまでループさせるという方法に落ち着いた。

他にもっと良い方法をご存知の方がいらっしゃいましたら、教えて下さい。

#include <iostream>
#include <string>
#include <unordered_map>
#include <regex>

using namespace std;

void    countFish();
void    countCrab();

int main()
{
    wcout.imbue(locale("japanese"));

    wcout << L"Fish" << endl;
    countFish();

    wcout << L"\nCrab" << endl;
    countCrab();

    return 0;
}

void    countFish()
{
    const wstring sFish{ L"鯵鯖鯵鯖鯵鯖鯵鯖鯵鯖鯵鯖鯵鯖鯵鯖鯵鯖鯵" };

    unordered_map<wstring, int> m;

    for (auto i = 0; i < sFish.length(); ++i)
        ++m[sFish.substr(i, 1)];

    for (const auto& mi : m)
        wcout << mi.first << L"::" << mi.second << endl;
}

void    countCrab()
{
    const wstring sCrab{ L"タラバガニ毛ガニタラバガニ毛ガニ越前蟹タラバガニ花咲蟹越前蟹越前蟹越前蟹ズワイガニズワイガニ越前蟹タラバガニズワイガニ" };

    unordered_map<wstring, int> m;

    wregex re(L"(?:(^|蟹|ガニ))(.+?)(蟹|ガニ)");

    wsmatch mc;

    auto it = sCrab.cbegin();
    while (regex_search(it, sCrab.cend(), mc, re))
    {
        ++m[mc[2].str() + mc[3].str()];

        it = mc.suffix().first;
    }

    for (const auto& mi : m)
        wcout << mi.first << L"::" << mi.second << endl;
}

実行結果