【VBA】FindFirstFileW、FindNextFileWを使ってファイルリストを取得する（Unicode 文字 対応版、64bit版）
FindFirstFileW による Unicode対応してみた
以前の記事で、FindFirstFile を使って、ファイルリストを取得するコードを書いたが、Unicode文字が含まれると文字化けするため修正してみた。
処理としては、ざっくりいうと、FindFirstFileA、FindNextFileA を使用していたものを、FindFirstFileW、FindNextFileW に変えた + 64bit対応したものである。
z1000s.hatenablog.com
2GB超のファイルサイズを求める
ついでなので、2GBを超えるファイルサイズを求める方法も追加してある。
以下の部分です。
fd.nFileSizeLow、fd.nFileSizeHigh が Long なので、&H7FFFFFFF ( 2,147,483,647 ) を超えると負数となるため、それを補正する必要がある。
そこで、LongLong 型の &HFFFFFFFF^、&H7FFFFFFF^ と And を取って Long 型ではなく、LongLong 型にキャストして処理している。
ちなみに、CLngLngは、下図の通りなので却下。
Dim llFileSize As LongLong llFileSize = fd.nFileSizeLow And &HFFFFFFFF^ llFileSize = llFileSize + (fd.nFileSizeHigh And &H7FFFFFFF^) * &H100000000^
失敗
2GB超対応で最初に考えたのは、WIN32_FIND_DATAW の、nFileSizeHigh と nFileSizeLow を合わせて、「LongLong のメンバーにまとめてしまえばいいのでは？」と考えたが、VBA の構造体が 4Byte パックなので、LongLong のメンバーにするとその境界を跨ぐため、あっさりと失敗に終わった。
あとから気が付いたが、リトルエンディアンだから、nFileSizeHigh が先にある時点で駄目なんだろう。
Private Type WIN32_FIND_DATAW dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName(MAX_PATH * 2 - 1) As Byte cAlternateFileName(27) As Byte dwFileType As Long dwCreatorType As Long wFinderFlags As Integer End Type
【VBA】SafeArrayGetDim を使って、配列の次元数を求める
ネットを見ていると、SafeArrayGetDim のVBA での宣言は、以下のように書かれているのを見かける。
Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32" (ByRef psa() As Any) As Long
しかし、MSのサイトの C++ 表記では、以下のようになっている。
UINT SafeArrayGetDim(
[in] SAFEARRAY *psa
);
引数は、SAFEARRAY を指すポインタであるので、今回の処理では、以下のようにして使っている。
（最初に書いた宣言で、配列を渡すと、意図した値は返ってこないようです。）
Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32" (ByVal psa As LongPtr) As Long
実行結果
備考
SAFEARRAY を指すポインタが取得できれば、SAFEARRAY 関連のAPIを使って出来ることが増えるかもしれません。
こちらのサイトを参考にさせていただきました。
www5f.biglobe.ne.jp
別解
2022/9/29 追記
SAFEARRAY を指すポインタが取得できたら、SafeArrayGetDim を呼ばずに、SAFEARRAY 構造体の先頭メンバー cDims を取得してもよさそう。
Dim iDims As Integer 'SAFEARRAY 構造体の戦闘メンバー cDims を引っ張ってくる Call RtlMoveMemory(iDims, ByVal pArray, Len(iDims))
【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
コード
ライセンス
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)
コード
トライ木
クラスモジュール：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 でした。
【VBA】Twitter お題 「280バイトを超えない範囲で区切りのよいところで分割したい」を解いてみた
Twitter のお題、
280バイトを超えない範囲で区切りのよいところで分割したい
を解いてみました。
お題は、こちら
【エクセルお題】
— エクセルの神髄 (@yamaoka_ss) 2020年6月14日
ツイートの下書きをA1セルに入れています。
バイト数はLENB関数で分かりますが、単純に280バイトで区切ってしまうと文章が尻切れになってしまいます。
そこで280バイトを超えない範囲で区切りのよいところで分割したい。
→画像に続く pic.twitter.com/Noiy2yJMT1
処理の概要
- 先頭から、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
実行結果
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
【VBA】Excelのユーザーフォームをフェードイン、フェードアウトさせてみた
はじめに
Windows では、Windows 2000 Professional 以降のバージョンで、ウインドウに対して、特定の拡張ウインドウスタイルを適用し、レイヤード ウィンドウ化することで、
- アルファブレンドによる、ウィンドウの半透過状態
- カラーキーによる、特定色部の透過
を行うことが出来るようになりました。
今回は、エクセルのユーザーフォームに対し、アルファブレンドを設定し、ユーザーフォームのフェードイン、フェードアウトを行ってみます。
Twitter に載せたやつを、少し修正したものです。
昨日の透過を使って、フォームのフェードイン、フェードアウトをやってみた。
— 空腹おやじ (@Z1000R_LR) 2020年5月12日
Forループで、SetLayeredWindowAttributes の bAlpha を増減しているだけ。 pic.twitter.com/Jz0LULXGIP
使用するAPI
FindWindow
ユーザーフォームのウィンドウハンドルを取得します。
HWND FindWindowA( LPCSTR lpClassName, LPCSTR lpWindowName );
今回は、手っ取り早く
lpClassNameには、vbNullString
lpWindowNameには、ユーザーフォームのCaptionを指定します。
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
実行サンプル
何かのネタに使えるようなら使ってみて下さい。
