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

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

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

2020-06-25

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

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

実行結果

検索対象ファイル
f:id:Z1000S:20200625222525p:plain

実行
f:id:Z1000S:20200625222715p:plain

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

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

f:id:Z1000S:20200625222844p:plain

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

参考

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

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

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

2020-06-14

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

VBA プログラミング Excel Twitterお題

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

お題は、こちら

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

処理の概要

先頭から、280バイト切り出し（末尾の２バイト文字がバラバラにならないように）
後ろから、区切り文字（"。" or LF）を検索
その位置まで、配列に格納
先頭位置を、移動して、280バイト未満になるまで繰り返し
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

実行結果
f:id:Z1000S:20200614185128p:plain

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

2020-05-27

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

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

f:id:Z1000S:20200527123246g:plain

2020-05-15

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

C++ プログラミング

ゴールデンウィークに行われた、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;
}

実行結果
f:id:Z1000S:20200515222616p:plain

2020-05-14

【VBA】Excelのユーザーフォームをフェードイン、フェードアウトさせてみた

VBA Excel プログラミング

はじめに
処理の概要
使用するAPI
コード
- 事前準備
- 標準モジュール
実行サンプル

はじめに

Windows では、Windows 2000 Professional 以降のバージョンで、ウインドウに対して、特定の拡張ウインドウスタイルを適用し、レイヤードウィンドウ化することで、

アルファブレンドによる、ウィンドウの半透過状態
カラーキーによる、特定色部の透過

を行うことが出来るようになりました。

今回は、エクセルのユーザーフォームに対し、アルファブレンドを設定し、ユーザーフォームのフェードイン、フェードアウトを行ってみます。

Twitter に載せたやつを、少し修正したものです。

昨日の透過を使って、フォームのフェードイン、フェードアウトをやってみた。

Forループで、SetLayeredWindowAttributes の bAlpha を増減しているだけ。 pic.twitter.com/Jz0LULXGIP
— 空腹おやじ (@Z1000R_LR) 2020年5月12日

処理の概要

簡単に言えば、以下の通り。
ただし、その処理を行うために、いくつかの準備等は必要です。

ユーザーフォームに対し、拡張スタイルを適用
アルファブレンド値を徐々に変化させる。

使用するAPI

FindWindow

ユーザーフォームのウィンドウハンドルを取得します。

HWND FindWindowA(
  LPCSTR lpClassName,
  LPCSTR lpWindowName
);

今回は、手っ取り早く
lpClassNameには、vbNullString
lpWindowNameには、ユーザーフォームのCaptionを指定します。

docs.microsoft.com

GetWindowLongPtr

指定したウィンドウのスタイルを取得します。

LONG_PTR GetWindowLongPtrA(
  HWND hWnd,
  int  nIndex
);

hWndには、FindWindowで取得した、ユーザーフォームのウインドウハンドルを指定します。
nIndexには、GWL_EXSTYLE を指定することで、ユーザーフォームに設定されている拡張ウィンドウスタイルを取得することができます。

SetWindowLongPtrA

指定したウィンドウに、スタイルを設定します。

LONG_PTR SetWindowLongPtrA(
  HWND     hWnd,
  int      nIndex,
  LONG_PTR dwNewLong
);

dwNewLong に、「GetWindowLongPtr で取得した拡張ウィンドウスタイルに対し、WS_EX_LAYEREDを追加した値を設定」することで、レイヤードウィンドウとすることができます。

SetLayeredWindowAttributes

今回の主役です。
ウィンドウの不透明度を設定します。
今回は使用しませんが、指定した色を透過させる事もできます。

BOOL SetLayeredWindowAttributes(
  HWND     hwnd,
  COLORREF crKey,
  BYTE     bAlpha,
  DWORD    dwFlags
);

crKeyには、レイヤードウィンドウを合成するときに使われる透明色キーを指定します。

bAlphaには、レイヤードウィンドウの不透明度を表現するために使用されるアルファ値を指定します。
値は、0 から 255 の範囲で、0を指定すると、ウィンドウは完全に透明になり、255を指定すると、ウィンドウは不透明になります。

dwFlagsには、LWA_ALPHA 、LWA_COLORKEY のいずれかひとつ、または両方を指定できます。
LWA_COLORKEY を指定すると、透過させる色の指定が有効になります。
LWA_ALPHA を指定すると、ウィンドウの不透明度の指定が有効になります。

拡張ウィンドウスタイル

拡張ウィンドウスタイルには、多数のスタイルがあり、今回はその中から、WS_EX_LAYERED を使用します。
docs.microsoft.com

コード

事前準備

予め、frmFade というユーザーフォームを作っておき、
Caption に、FadeForm という文字列を設定しておきます。

標準モジュール

掲載しているのは、64bit版のコードです。

32bit版で使用する場合には、いくつかの修正が必要です。
32bit環境がないので、未確認ですが、最低でも以下の修正が必要と思われます。

Declare の PtrSafe 削除
GetWindowLongPtr ==> GetWindowLong
GetWindowLongPtr のreturn LongPtr ==> Long
SetWindowLongPtr ==>SetWindowLong
SetWindowLongPtr の dwNewLong の型 LongPtr ==> Long
hwnd の型 LongPtr ==> Long
lExStyle の型 LongPtr ==> Long

Option Explicit

Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1&
Private Const LWA_ALPHA = &H2&
Private Const GWL_EXSTYLE = -20&

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
       (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr

Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" _
       (ByVal hwnd As LongPtr, _
        ByVal nIndex As Long) As LongPtr

Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _
       (ByVal hwnd As LongPtr, _
        ByVal nIndex As Long, _
        ByVal dwNewLong As LongPtr) As LongPtr

Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" _
       (ByVal hwnd As LongPtr, _
        ByVal crKey As Long, _
        ByVal bAlpha As Long, _
        ByVal dwFlags As Long) As Long

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)


Public Sub showForm()

    Dim f           As frmFade
    Dim hwnd        As LongPtr
    Dim lExStyle    As LongPtr
    Dim lResult     As Long
    Dim i       As Long

    Set f = frmFade

    'いきなり f.Show とすると、表示されてしまうので、Load するだけ
    Load f

    'タイトルを使って、ウィンドウハンドルを取得する
    hwnd = FindWindow(vbNullString, "FadeForm")

    lExStyle = GetWindowLongPtr(hwnd, GWL_EXSTYLE)

    If (lExStyle And WS_EX_LAYERED) = 0 Then
        'WS_EX_LAYEREDが未設定なら、拡張スタイルに、WS_EX_LAYERED を付与する
        lExStyle = lExStyle Or WS_EX_LAYERED

        Call SetWindowLongPtr(hwnd, GWL_EXSTYLE, lExStyle)
    End If

    '初期は､完全透過状態で表示させる
    Call SetLayeredWindowAttributes(hwnd, 0, 0, LWA_ALPHA)

    f.Show

    For i = 5 To 255 Step 5
        '不透明度を、上げていく
        Call SetLayeredWindowAttributes(hwnd, 0, i, LWA_ALPHA)

        DoEvents

        Call Sleep(40)
    Next i

    Call Sleep(1000)

    For i = 255 To 0 Step -5
        '不透明度を、下げていく
        Call SetLayeredWindowAttributes(hwnd, 0, i, LWA_ALPHA)

        DoEvents

        Call Sleep(40)
    Next i

    Unload f

    Set f = Nothing

End Sub

実行サンプル

f:id:Z1000S:20200514211257g:plain

何かのネタに使えるようなら使ってみて下さい。

2020-02-25

【VBA】Twitter お題「ねこちゃんの数を数える」を解いてみた

VBA プログラミング正規表現

Twitter で、ほえほえ氏から提示されたお題「ねこちゃんの数を数える」を解いてみた。

少しお題を考えたので投稿してみます。お題のためのお題ということで少し不自然だし、簡単な解法があるかもしれませんがご容赦を。発展型で言ってみます。

お題　ねこちゃんの数を数える

です。（つづく）
— ほえほえ＠LWP (@hoehoe1234) 2020年2月23日

ざっくり言えば、「親猫」、「子猫」、「猫又」・・・といった文字が並んでいて、
それぞれ何匹いるのかを数えるというもの。

take 1からtake 7まであって、
それぞれに条件がついています。

Take	条件	文字列
1	親猫と子猫を数えて（数と種類を報告）ください。	親猫子猫子猫子猫子猫子猫子猫親猫親猫子猫子猫
2	簡潔に書くために同じ種類の猫が連続する場合は「猫」一文字で代用することにしました。「親猫猫子猫猫」は、親猫が２匹、子猫が２匹です。	親猫猫猫子猫猫猫猫猫猫親猫子猫猫
3	せっかく簡潔に書く記法を開発したのに適当に書くやつが現れました。そのせいで繰り返しの代わりに元の記法もOKになりました。親猫が３匹の場合下のいづれもOKとします。親猫親猫親猫親猫猫親猫親猫猫猫	子猫猫子猫猫親猫猫子猫親猫子猫親猫子猫猫子猫
4	なんと列に「猫又」が混じってしまいました。親猫、子猫、猫又の数を数えてください。	子猫猫子猫猫親猫猫又猫猫猫又親猫猫猫猫又猫
5	いままでは親猫子猫猫又でしたがいろいろな種類の猫がが混じってしまいました。ただし猫の名前は２文字で最後に「猫」がつくのは同じです。例で白猫黒猫がいますが実際はもっとたくさんの種類がいます。（青猫、緑猫とか）	子猫猫白猫黒猫猫猫猫親猫猫又猫猫猫又親猫猫猫猫又猫
6	なんと不条理な上司！登場。あろうことか、「猫又が二匹現れたらその時点で猫の種類と数を報告して作業を終了せよ」といわれました。どうしよう。。。上司によると猫又２匹とは「累計して２匹」現れたらとのことで、連続２匹ということではない模様です。 "子猫猫又親猫猫又" "子猫親猫猫又猫" はともに最後の猫又で「累計２匹」なのでそこで報告して作業終了です。	子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫猫又青猫親猫猫猫猫又猫
7	最後の試練。上司が逆ギレしています。どうやら先程の指示は上司の意図ではなかったようです。彼によると「猫又が不吉なのは『きっちり２匹だけ並んだ』ときだけだ！」とのことです。累計でもないしなんと猫又が３匹並んでもそれはOK（カウント継続）だそうです。数えられるかな、、、、

コード

手っ取り早いので、正規表現で・・・

メイン処理

参照設定は、いつものやつ。
Microsoft VBScript Regular Expressions 5.5

メイン処理で使っているパターンは、
親猫を数える場合を例に取ると

(?:親)(猫*?)(?=(?:猫又|[^猫]|$))

猫に続く猫又を分けなければいけないので
肯定先読みを使用している。

"親猫又"
がある場合には、
猫又
を優先している。

親猫を優先したい場合には、
"(猫*?)"を"(猫+?)"に変えればいい（はず）。

(?:親)(猫+?)(?=(?:猫又|[^猫]|$))

親の部分が変わるだけで、
Take 1 から、Take 7 まで全て同じパターンで処理している。

Public Function 猫5改2(ByVal sCats As String, ByRef sCatType() As String, ByRef lCatCount() As Long) As Long

    Dim re          As RegExp
    Dim mc          As MatchCollection
    Dim lCount      As Long
    Dim lNekomata   As Long
    Dim sResult     As String
    Dim sTypes()    As String
    Dim lElems      As Long
    Dim i       As Long
    Dim j       As Long

    ReDim sCatType(lCount)
    ReDim lCatCount(lCount)

    '猫又
    lNekomata = (Len(sCats) - Len(Replace$(sCats, "猫又", ""))) \ 2

    If lNekomata > 0 Then
        ReDim Preserve sCatType(lCount)
        sCatType(lCount) = "猫又"

        ReDim Preserve lCatCount(lCount)
        lCatCount(lCount) = lNekomata

        lCount = lCount + 1
    End If

    猫5改2 = lCount

    '猫と又を消して、猫の種類の文字のみにする
    sResult = Replace$(sCats, "猫", "")
    sResult = Replace$(sResult, "又", "")

    ReDim sTypes(0)

    lElems = -1

    '"猫"の前に付く文字を抜き出す（"又"は含まれない）
    Do Until Len(sResult) = 0
        lElems = lElems + 1

        ReDim Preserve sTypes(lElems)

        sTypes(lElems) = Left$(sResult, 1)

        sResult = Replace$(sResult, sTypes(lElems), "")
    Loop

    If lElems < 0 Then
        Exit Function
    End If

    Set re = New RegExp

    With re
        .Global = True

        For i = LBound(sTypes) To UBound(sTypes)
            .Pattern = "(?:" & sTypes(i) & ")(猫*?)(?=(?:猫又|[^猫]|$))"

            Set mc = .Execute(sCats)

            sResult = ""

            For j = 0 To mc.Count - 1
                sResult = sResult & mc.Item(j).SubMatches(0)
            Next j

CONTINUE_LOOP:
            If sCats Like "*" & sTypes(i) & "猫*" Then
                '"親子猫"のような場合、"親猫"は無いので出力しない
                If Not sCats Like "*" & sTypes(i) & "猫又*" Then
                    '"子猫又"のような場合、"子猫"を出力しない

                    ReDim Preserve sCatType(lCount)
                    sCatType(lCount) = sTypes(i) & "猫"

                    ReDim Preserve lCatCount(lCount)
                    lCatCount(lCount) = Len(sResult) - Len(Replace$(sResult, "猫", ""))

                    lCount = lCount + 1
                End If
            End If
        Next i
    End With

    猫5改2 = lCount

End Function

Take 6、Take 7用補助処理

Public Function get猫6Source(ByVal sCats As String) As String

    Dim re      As RegExp
    Dim mc      As MatchCollection
    Dim sSource As String
    Dim lResult As Long
    Dim i       As Long

    Set re = New RegExp

    With re
        .Pattern = "^(.*?猫又){2}"
        .Global = False

        Set mc = .Execute(sCats)
        
        If mc.Count > 0 Then
            sSource = mc.Item(0)
        Else
            sSource = sCats
        End If
    End With

    get猫6Source = sSource

End Function

Public Function get猫7Source(ByVal sCats As String) As String

    Dim re      As RegExp
    Dim mc      As MatchCollection
    Dim sSource As String

    Set re = New RegExp

    With re
        .Pattern = "^.*?[^又]猫又猫又(?!猫又)"
        .Global = True

        Set mc = .Execute(sCats)
        
        If mc.Count > 0 Then
            sSource = mc.Item(0)
        Else
            sSource = sCats
        End If
    End With

    get猫7Source = sSource

End Function

テスト

Public Sub 猫てすと()

    Dim sCatType()  As String
    Dim lCatCount() As Long

    Dim sCats       As String
    Dim lResult     As Long

    '----- take1 -----
    Erase sCatType, lCatCount

    sCats = "親猫子猫子猫子猫子猫子猫子猫親猫親猫子猫子猫"
    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "親猫"
    Debug.Assert lCatCount(0) = 3
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 8

    '----- take2 -----
    Erase sCatType, lCatCount

    sCats = "親猫猫猫子猫猫猫猫猫猫親猫子猫猫"
    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "親猫"
    Debug.Assert lCatCount(0) = 4
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 8

    '----- take3 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫子猫猫親猫猫子猫親猫子猫親猫子猫猫子猫"
    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "子猫"
    Debug.Assert lCatCount(0) = 9
    Debug.Assert sCatType(1) = "親猫"
    Debug.Assert lCatCount(1) = 4

    '----- take4 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫子猫猫親猫猫又猫猫猫又親猫猫猫猫又猫"
    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 3
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 3
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 4
    Debug.Assert sCatType(2) = "親猫"
    Debug.Assert lCatCount(2) = 4

    '----- take5 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫猫猫猫親猫猫又猫猫猫又親猫猫猫猫又猫"
    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 5
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 3
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 2
    Debug.Assert sCatType(2) = "白猫"
    Debug.Assert lCatCount(2) = 1
    Debug.Assert sCatType(3) = "黒猫"
    Debug.Assert lCatCount(3) = 4
    Debug.Assert sCatType(4) = "親猫"
    Debug.Assert lCatCount(4) = 4

    '----- take6-1 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫猫又青猫親猫猫猫猫又猫"
    sCats = get猫6Source(sCats)

    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 7
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 2
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 2
    Debug.Assert sCatType(2) = "白猫"
    Debug.Assert lCatCount(2) = 1
    Debug.Assert sCatType(3) = "黒猫"
    Debug.Assert lCatCount(3) = 1
    Debug.Assert sCatType(4) = "緑猫"
    Debug.Assert lCatCount(4) = 1
    Debug.Assert sCatType(5) = "青猫"
    Debug.Assert lCatCount(5) = 4
    Debug.Assert sCatType(6) = "親猫"
    Debug.Assert lCatCount(6) = 1

    '----- take6-12 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫青猫親猫猫猫猫"
    sCats = get猫6Source(sCats)

    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 7
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 1
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 2
    Debug.Assert sCatType(2) = "白猫"
    Debug.Assert lCatCount(2) = 1
    Debug.Assert sCatType(3) = "黒猫"
    Debug.Assert lCatCount(3) = 1
    Debug.Assert sCatType(4) = "緑猫"
    Debug.Assert lCatCount(4) = 1
    Debug.Assert sCatType(5) = "青猫"
    Debug.Assert lCatCount(5) = 5
    Debug.Assert sCatType(6) = "親猫"
    Debug.Assert lCatCount(6) = 5

    '----- take7-1 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫猫又青猫親猫猫猫猫又猫"
    sCats = get猫7Source(sCats)

    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 7
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 3
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 2
    Debug.Assert sCatType(2) = "白猫"
    Debug.Assert lCatCount(2) = 1
    Debug.Assert sCatType(3) = "黒猫"
    Debug.Assert lCatCount(3) = 1
    Debug.Assert sCatType(4) = "緑猫"
    Debug.Assert lCatCount(4) = 1
    Debug.Assert sCatType(5) = "青猫"
    Debug.Assert lCatCount(5) = 5
    Debug.Assert sCatType(6) = "親猫"
    Debug.Assert lCatCount(6) = 4

    '----- take7-2 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫又青猫親猫猫猫猫又猫"
    sCats = get猫7Source(sCats)

    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 7
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 2
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 2
    Debug.Assert sCatType(2) = "白猫"
    Debug.Assert lCatCount(2) = 1
    Debug.Assert sCatType(3) = "黒猫"
    Debug.Assert lCatCount(3) = 1
    Debug.Assert sCatType(4) = "緑猫"
    Debug.Assert lCatCount(4) = 1
    Debug.Assert sCatType(5) = "青猫"
    Debug.Assert lCatCount(5) = 4
    Debug.Assert sCatType(6) = "親猫"
    Debug.Assert lCatCount(6) = 1

    Debug.Print "Done."

End Sub

Debug.Assert で済ませたので、イミディエイトウィンドウに

Done.

と出て、終わり。

ちなみに、イミディエイトウィンドウに出力すると、こんな感じ。
f:id:Z1000S:20200225224939p:plain

以上。

「改2」は、バージョンです。ツッコまないでくださいwww

正規表現を使わないバージョン（2020/3/1追加）

Take 1～5 限定です。
正規表現バージョンより、精度が低いです。
お題で提示されているデータは、クリアしますが、元になる猫データが変わると、要件をクリアできない場合があります。
正規表現バージョンとは、出力順が違います。

コード

Public Function 猫猫(ByVal sCats As String, ByRef sCatType() As String, ByRef lCatCount() As Long) As Long

    Dim dicCount    As Dictionary
    Dim lLength     As Long
    Dim lStartPos   As Long
    Dim lOffset     As Long
    Dim sCurrentType    As String
    Dim sType       As String
    Dim lCount      As Long

    lLength = Len(sCats)

    If lLength < 2 Then
        Exit Function
    End If

    Set dicCount = New Dictionary

    'グループ開始位置
    lStartPos = 1
    lOffset = 0

    '現在の猫の種類
    sCurrentType = ""
    sType = Mid$(sCats, lStartPos, 1)

    Do While True
        Select Case sType
        Case "猫"
            If Mid$(sCats, lStartPos + lOffset + 1, 1) <> "又" Then
                '猫又ではない
                lCount = lCount + 1
                lOffset = lOffset + 1
            Else
                '猫又
                lStartPos = lStartPos + lOffset + 2
                lOffset = 0

                If dicCount.Exists("又") = True Then
                    dicCount.Item("又") = dicCount.Item("又") + 1
                Else
                    dicCount.Add "又", 1
                End If

                If Len(sCurrentType) > 0 Then
                    If dicCount.Exists(sCurrentType) = True Then
                        dicCount.Item(sCurrentType) = dicCount.Item(sCurrentType) + lCount
                    End If
                End If

                sCurrentType = ""
            End If
        Case Else
            If sCurrentType <> sType Then
                '猫の種類が変わった
                lStartPos = lStartPos + lOffset + 1
                lOffset = 0

                If dicCount.Exists(sCurrentType) = True Then
                    'カウントアップ
                    dicCount.Item(sCurrentType) = dicCount.Item(sCurrentType) + lCount
                End If

                If Len(sType) > 0 Then
                    If dicCount.Exists(sType) = False Then
                        '新しい猫の種類を追加
                        dicCount.Add sType, 0
                    End If
                End If

                '現在の猫の種類を更新
                sCurrentType = sType

                'カウントクリア
                lCount = 0
            Else
                lOffset = lOffset + 1
            End If
        End Select

        sType = Mid$(sCats, lStartPos + lOffset, 1)

        '終了判定（lStartPos + lOffset > lLength で、sType = ""となる）
        If Len(sType) = 0 Then
            If Len(sCurrentType) > 0 Then
                '有効データならカウントアップ
                dicCount.Item(sCurrentType) = dicCount.Item(sCurrentType) + lCount
            End If

            Exit Do
        End If
    Loop

'--------------------------------------------------
    Dim v As Variant
    Dim lElems  As Long

    ReDim sCatType(dicCount.Count - 1)
    ReDim lCatCount(dicCount.Count - 1)

    For Each v In dicCount
        If Len(v) > 0 Then
            If dicCount.Item(v) > 0 Then
                If v <> "又" Then
                    sCatType(lElems) = v & "猫"
                Else
                    sCatType(lElems) = "猫" & v
                End If
                lCatCount(lElems) = dicCount.Item(v)

                lElems = lElems + 1
            End If
        End If
    Next v

    If dicCount.Count <> lElems Then
        '未登録データが有れば、排除
        ReDim Preserve sCatType(lElems - 1)
        ReDim Preserve lCatCount(lElems - 1)
    End If

    猫猫 = lElems

End Function

テスト

Public Sub 猫猫テスト()

    Dim sCatType()  As String
    Dim lCatCount() As Long

    Dim sCats       As String
    Dim lResult     As Long

    '----- take1 -----
    Erase sCatType, lCatCount

    sCats = "親猫子猫子猫子猫子猫子猫子猫親猫親猫子猫子猫"
    lResult = 猫猫(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "親猫"
    Debug.Assert lCatCount(0) = 3
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 8

    '----- take2 -----
    Erase sCatType, lCatCount

    sCats = "親猫猫猫子猫猫猫猫猫猫親猫子猫猫"
    lResult = 猫猫(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "親猫"
    Debug.Assert lCatCount(0) = 4
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 8

    '----- take3 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫子猫猫親猫猫子猫親猫子猫親猫子猫猫子猫"
    lResult = 猫猫(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "子猫"
    Debug.Assert lCatCount(0) = 9
    Debug.Assert sCatType(1) = "親猫"
    Debug.Assert lCatCount(1) = 4

    '----- take4 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫子猫猫親猫猫又猫猫猫又親猫猫猫猫又猫"
    lResult = 猫猫(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 3
    Debug.Assert sCatType(0) = "子猫"
    Debug.Assert lCatCount(0) = 4
    Debug.Assert sCatType(1) = "親猫"
    Debug.Assert lCatCount(1) = 4
    Debug.Assert sCatType(2) = "猫又"
    Debug.Assert lCatCount(2) = 3

    '----- take5 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫猫猫猫親猫猫又猫猫猫又親猫猫猫猫又猫"
    lResult = 猫猫(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 5
    Debug.Assert sCatType(0) = "子猫"
    Debug.Assert lCatCount(0) = 2
    Debug.Assert sCatType(1) = "白猫"
    Debug.Assert lCatCount(1) = 1
    Debug.Assert sCatType(2) = "黒猫"
    Debug.Assert lCatCount(2) = 4
    Debug.Assert sCatType(3) = "親猫"
    Debug.Assert lCatCount(3) = 4
    Debug.Assert sCatType(4) = "猫又"
    Debug.Assert lCatCount(4) = 3

    Debug.Print "Done."

End Sub

空腹おやじのログと備忘録

VBA（主にExcel）でいろいろな実験的な事とか、Linuxのコマンドとか設定とかについて忘れないように、あれこれと・・・

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

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

前置き

コード

実行結果

参考

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

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

コード

実行例

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

【VBA】Excelのユーザーフォームをフェードイン、フェードアウトさせてみた

はじめに

処理の概要

使用するAPI

FindWindow

GetWindowLongPtr

SetWindowLongPtrA

SetLayeredWindowAttributes

拡張ウィンドウスタイル

コード

事前準備

標準モジュール

実行サンプル

【VBA】Twitter お題「ねこちゃんの数を数える」を解いてみた

コード

メイン処理

Take 6、Take 7用補助処理

テスト

正規表現を使わないバージョン（2020/3/1追加）