VBAでファイルリストを高速に取得する関数を自作する part4

今回は前回の「VBAでファイルリストを高速に取得する関数」に改良を加えて更に高速化すると共に64bit対応に成功しましたのでその軌跡を記します。

---

まえがき

前回はWindows APIを使用することで、様々なリスクを解消しつつFileSystemObjectの数十倍の速度でファイルリストを作成する関数の開発に成功しました。

www.excel-chunchun.com

早速アドインの関数を置き換えをしたのですが…あのままでは64bitには対応していないことが判明しました。

具体的に言うとExcelが落ちます。それはもう。無言で。静かに。あっけなく。

ここで結論を言ってしまうと、関数の戻り値の型指定がLongをLongPtrに変えてなかったからです。

それだけなら元の記事をコソっと直すだけのつもりでいました。

しかし、ヒントを求めて検索を繰り返しているうちに、FindFirstFileExという関数を発見。

そして気になるコメントが・・・。

https://kkamegawa.hatenablog.jp/entry/20100918/p1

長い間、NTFSチューニングの一つに「短いファイル名を生成させない」という技がありました。Windows Server 2008 R2のベストプラクティスアナライザーでも遅いディスクに対してはこのアドバイスが下されます。 NTFS Performance with Numerous Long Filenames とはいっても、短いファイル名の生成をやめると、どうしても互換性の問題が発生します。短いファイル名を意図的に使っている場合もあります。空白ファイル名使うときめんどくさいですしね…。じゃあ、OSのほうでなんとかすればいいじゃないってことで、遅まきながらWindows 7でフラグが追加されることになりました。FindExInfoBasicを指定すれば、短いファイル名をWIN32_FIND_DATA構造体に格納せず、少し早くなると書かれています。

手元の環境で81%くらいの時間になりました。

つまり、短いファイル名(8.3形式のファイル名cAlternateFileName)の取得を省略することで、さらなる高速化が見込めるみたいです。

これはやってみるしかない！！！

というわけで、今回はFindFirstFileExW関数を使って、ファイルリストの作成に挑戦します。

また、StrCmpLogicalW関数も取り入れて、ファイルリストの順序をエクスプローラと同じ並び順になるようにソートした状態で取得できないか、試したいと思います。

FindFirstFileExW 関数

参考資料

FindFirstFileExW の使用にあたって、私の語学力ではMSDNの説明が理解できなかったので、この辺りの記事も参考にしつつ情報を整理しました。

Yahooブログ 特になし - FindFirstFileEx

Excel VBA質問箱 IV - 【58244】Re:再帰処理でのファイル検索

GitHub - kumatti1/Module1.bas

概要

FindFirstFileExW 関数

HANDLE FindFirstFileExW(
  LPCWSTR            lpFileName,
  FINDEX_INFO_LEVELS fInfoLevelId,
  LPVOID             lpFindFileData,
  FINDEX_SEARCH_OPS  fSearchOp,
  LPVOID             lpSearchFilter,
  DWORD              dwAdditionalFlags
);

lpFileName

検索したいファイル名の文字列をワイルドカードで指定

FindFirstFileと同様。

先頭に "\?\"や"\?\UNC" を追加しておくとMAX_PATHよりも長い文字をパスに指定することが出来る。

例:"\\?\C:\hoge\*"

fInfoLevelId

返されるデータの情報レベルを表す FINDEX_INFO_LEVELS 列挙型を指定

基本的にはFindExInfoBasic を指定しておけばOK

lpFindFileData

検索結果のファイル情報を格納するWIN32_FIND_DATA 構造体を指定

FindFirstFileと同様

fSearchOp

ワイルドカードとの照合以外のフィルタ処理タイプを表すFINDEX_SEARCH_OPS 列挙型を指定

FindExSearchNameMatchを指定する

lpSearchFilter

検索条件へのポインタを指定

FindExSearchNameMatchの時はNULLにしろとのこと。

つまりVBAでは0&でOK

dwAdditionalFlags

補足的な検索制御フラグ。

収集した情報をまとめると、

Private Const FIND_FIRST_EX_CASE_SENSITIVE = 1& 検索では大文字と小文字が区別されます。

Private Const FIND_FIRST_EX_LARGE_FETCH = 2& ディレクトリー照会にはより大きなバッファーを使用します。 これにより、検索操作のパフォーマンスが向上する可能性があります。 Windows Server 2008、Windows Vista、Windows Server 2003、およびWindows XP： この値は、Windows Server 2008 R2およびWindows 7まではサポートされていません。

Private Const FIND_FIRST_EX_ON_DISK_ENTRIES_ONLY = 4& 結果を物理的にディスク上にあるファイルに制限します。 このフラグは、ファイル仮想化フィルタが存在する場合にのみ関係します。

という感じです。

戻り値

FindFirstFileと同様

成功したらファイルハンドルを返す。

見つからない場合はINVALID_HANDLE_VALUEを返す。

WindowsXPのExcel 2007で実行した場合も、INVALID_HANDLE_VALUEが返却された。

WIN32_FIND_DATA 構造体

 typedef struct _WIN32_FIND_DATAA {
   DWORD    dwFileAttributes;
   FILETIME ftCreationTime;
   FILETIME ftLastAccessTime;
   FILETIME ftLastWriteTime;
   DWORD    nFileSizeHigh;
   DWORD    nFileSizeLow;
   DWORD    dwReserved0;
   DWORD    dwReserved1;
   CHAR     cFileName[MAX_PATH];
   CHAR     cAlternateFileName[14];
   DWORD    dwFileType;
   DWORD    dwCreatorType;
   WORD     wFinderFlags;
 } WIN32_FIND_DATAA, *PWIN32_FIND_DATAA, *LPWIN32_FIND_DATAA;

FINDEX_INFO_LEVELS 列挙型

typedef enum _FINDEX_INFO_LEVELS {
FindExInfoStandard,
FindExInfoBasic,
FindExInfoMaxInfoLevel
} FINDEX_INFO_LEVELS;

FindExInfoStandard : FindFirstFileと同じ動作になる。

FindExInfoBasic : WIN32_FIND_DATAのcAlternateFileNameに短いファイル名(8.3形式)を取得しない。Windows7以降対応。

FindExInfoMaxInfoLevel : 検証用らしい。This value is used for validation. Supported values are less than this value.

8.3形式のファイル名なんて今どき必要ないですから、FindExInfoBasicにしておくのが無難です。

これがFindFirstFileよりもFindFirstFileExのほうが高速化できる理由です。

FINDEX_SEARCH_OPS 列挙型

 typedef enum _FINDEX_SEARCH_OPS {
 FindExSearchNameMatch,
 FindExSearchLimitToDirectories,
 FindExSearchLimitToDevices,
 FindExSearchMaxSearchOp
 } FINDEX_SEARCH_OPS;

FindExSearchNameMatch : 指定したファイル名と一致するファイルを検索

色々調べてみましたが、他の値はいずれも未サポートだったり、利用不能だったりという検証結果しか見つかりませんでした。

実質FindExSearchNameMatch固定です。

使用例

以上をまとめると、ソースコードはこんな感じになります。

Dim findData As WIN32_FIND_DATA
Dim fileHandle As LongPtr
fileHandle = FindFirstFileEx( _
    StrPtr("\\?\C:\hoge\*"), _
    FindExInfoBasic, _
    findData, _
    FindExSearchNameMatch, _
    0&, _
    FIND_FIRST_EX_LARGE_FETCH)

StrCmpLogicalW関数

概要

エクスプローラと同じファイル順に並び替えるのに必要な関数です。

int StrCmpLogicalW(
  PCWSTR psz1,
  PCWSTR psz2
);

lpStr1

１つ目のファイルパス

lpStr2

2つ目のファイルパス

戻り値

二つのファイル名が降順だと1、同じなら0、昇順なら-1を返す

2つの文字列を比較して結果を教えてくれるだけのシンプルな関数です。

ファイル一覧、フォルダ一覧が取得できるたびに回していくことになります。

使用例

ソート関数は下記のものを参考にしました。

http://hk29.hatenablog.jp/entry/2018/03/10/183447

Sub StrCmpLogical_Sort(ByRef Arr() As String)
    Dim i As Long, j As Long
    Dim tmp As String

    For i = LBound(Arr) To UBound(Arr)
        For j = i To UBound(Arr)
            If StrCmpLogicalW(StrConv(Arr(i), vbUnicode), _
                              StrConv(Arr(j), vbUnicode)) > 0 Then
                Let tmp = Arr(i)
                Let Arr(i) = Arr(j)
                Let Arr(j) = tmp
            End If
       Next
    Next
End Sub

疑問

注意したいのはこの記述

If StrCmpLogicalW(StrConv(myArray(i), vbUnicode), _
                  StrConv(myArray(j), vbUnicode)) > 0 Then

検索すると次のようにStrPtrを使って書かれているサイトが有りました。

[半角チルダ - ■XPエクスプローラ風「数値順」ソート

If StrCmpLogicalW(StrPtr(myArray(i)), _
                  StrPtr(myArray(j))) > 0 Then

ところが、この方法だと、実行するたびに並び順がランダムに変わるのです。

2013年の記事なので、昔で仕様が変わったのでしょうか。

何故このような現象が起こるのか、まだ研究できていません。

ファイルを返す順番については下記のサイトの解説が参考になりそうです。

Office TANAKA - ファイルの一覧を取得する

ソースコード

ファイルリスト作成モジュール

GetFileFolderList関数を使えるようにするには、下記のコードを標準モジュールとして追加してください。

▶ソースコードを展開

Rem Unicode対応版ファイルリスト作成関数
Rem
Rem ■公開先
Rem
Rem えくせるちゅんちゅん
Rem 2019/04/27
Rem VBAでファイルリストを高速に取得する関数を自作するPart4
Rem https://www.excel-chunchun.com/entry/2019/04/27/GetFileList_04
Rem
Rem ----------------------------------------------------------------------------------------------------
Rem
Rem ■参考資料
Rem
Rem Excelが大好きだ！
Rem 2019/03/04
Rem サブフォルダ内を含むWindows API(FindFirstFileW)を利用したファイル検索（ファイル検索比較６）
Rem https://www.excellovers.com/entry/filesearch07
Rem
Rem 空腹おやじのログと備忘録
Rem 2019/04/10
Rem VBAでFindFirstFile、FindNextFileを使ってファイルリストを取得する
Rem https://z1000s.hatenablog.com/entry/2019/04/10/145606
Rem
Rem ----------------------------------------------------------------------------------------------------
Rem
Rem ■更新履歴
Rem
Rem 2019/04/24 : 初回リリース
Rem 2019/04/26 : 4/25ブログコメントの指摘を元に修正
Rem 2019/04/27 : 64bit対応。APIをExに変更。エクスプローラ順ソートに対応。
Rem
Rem ----------------------------------------------------------------------------------------------------
Rem
Rem ■使い方
Rem
Rem 低速なFileSystemObjectを使わずに、WindowsAPIのみを使用してファイルリストを
Rem 作成するための関数です。
Rem 私が必要とする独特な機能を搭載しています。
Rem
Rem 以下、注意事項です。
Rem
Rem 1.parentFolderは末尾に\を付けたフォルダパスを指定してください。
Rem    parentFolder :     -   :  必須  : 検索対象フォルダの末尾が\で終わるパス
Rem
Rem    末尾に\が無いと実行時エラーを発生させます。
Rem
Rem 2.AddFileとAddFolderを省略すると、何も取得されません。
Rem    AddFile      :  False  : 省略可 : ファイルを対象に含めるか
Rem    AddFolder    :  False  : 省略可 : フォルダを対象に含めるか
Rem
Rem    少なくとも検索したいどちらかをTrueにしてください。
Rem
Rem 3.SubMinとSubMaxを省略すると、直下のモノしか取得しません。
Rem    SubMin       :      0  : 省略可 : 何階層以降を探索するか（0～n、-1の時は無制限）
Rem    SubMax       :      0  : 省略可 : 何階層以前を探索するか（0～n、-1の時は無制限）
Rem
Rem    parentFolderで指定したパス直下を第0階層としてカウントします。
Rem    よって、SubMinの省略、0、-1は全て同義です。
Rem
Rem　　配下の全てのファイルを取得したい場合は、-1,-1になります。
Rem    あるいは、0,9999としても実質的に同じ結果が得られます。
Rem
Rem　　※既定値を配下全てのファイルとすると、莫大な時間がかかる恐れがあるためです。
Rem
Rem 4.戻り値はparentFolderから見た【相対パス】になります。
Rem    絶対パスを返すようにすると、全てのモノに同一の文字列が付与されるため、
Rem    深い階層で検索を開始した時にメモリを無駄に消費するのを防ぐためです。
Rem    したがって、取り出したアイテムはparentFolderと連結してから使用します。
Rem
Rem    また、フォルダの末尾には必ず\を付与した状態で返します。
Rem    ※パス文字列からファイルとフォルダを識別できるようにするためです。
Rem
Rem 5.並び順はファイル→フォルダです。
Rem
Rem    ※たぶんエクスプローラで表示される順序とは異なります。
Rem    ※今後、仕様が変わる恐れがあります。
Rem
Rem    例
Rem      A001.txt
Rem      A002.txt
Rem      A01\
Rem      A01\B001.txt
Rem      A01\B002.txt
Rem      A01\B1001\
Rem      A01\B1001\C001.txt
Rem      A01\B1001\C002.txt
Rem      A01\B1001\C2001\
Rem      A01\B1001\C2001\001.txt
Rem      A01\B1001\C2001\002.txt
Rem      A01\B1001\C2002\
Rem      A01\B1001\C2002\001.txt
Rem      A01\B1001\C2002\002.txt
Rem      A01\B1002\
Rem      A01\B1002\C001.txt
Rem      A01\B1002\C002.txt
Rem      A01\B1002\C2001\
Rem      A01\B1002\C2001\001.txt
Rem      A01\B1002\C2001\002.txt
Rem      A01\B1002\C2002\
Rem      A01\B1002\C2002\001.txt
Rem      A01\B1002\C2002\002.txt
Rem
Rem Sub Sample_GetFileList_API()
Rem
Rem     Const SEARCH_PATH = "D:\test\"
Rem
Rem     Dim colPaths As Collection
Rem
Rem     Set colPaths = GetFileFolderList(SEARCH_PATH)
Rem     Debug.Print "何も取得せず", colPaths.Count
Rem
Rem     Set colPaths = GetFileFolderList(SEARCH_PATH, True)
Rem     Debug.Print "指定パスのファイルのみ取得", colPaths.Count
Rem
Rem     Set colPaths = GetFileFolderList(SEARCH_PATH, True, True)
Rem     Debug.Print "指定パスのファイルとフォルダを取得", colPaths.Count
Rem
Rem     Set colPaths = GetFileFolderList(SEARCH_PATH, True, True, 2, 2)
Rem     Debug.Print "第二階層のファイルとフォルダを取得", colPaths.Count
Rem
Rem     Set colPaths = GetFileFolderList(SEARCH_PATH, True, True, 3, -1)
Rem     Debug.Print "第三階層以下のファイルとフォルダを取得", colPaths.Count
Rem
Rem     Set colPaths = GetFileFolderList(SEARCH_PATH, True, True, -1, -1)
Rem     Debug.Print "指定パス以下の全てのファイルとフォルダを取得", colPaths.Count
Rem
Rem End Sub
Rem ----------------------------------------------------------------------------------------------------

Option Explicit

Private Const INVALID_HANDLE_VALUE = -1

'FindFirstFileEx関数を使用するか
'Trueにした場合でも、失敗したら自動でFindFirstFileで対応する
Private Const USE_FindFirstFileEx = True

Rem ----------------------------------------------------------------------------------------------------
Rem Win32API関数参照
Rem
Rem 先頭ファイル検索
#If VBA7 Then
Rem http://chokuto.ifdef.jp/urawaza/api/FindFirstFile.html
Rem https://docs.microsoft.com/ja-jp/windows/desktop/api/fileapi/nf-fileapi-findfirstfilew
Private Declare PtrSafe Function FindFirstFile Lib "kernel32" Alias "FindFirstFileW" _
            (ByVal lpFileName As LongPtr, _
            lpFindFileData As WIN32_FIND_DATA) As LongPtr
            
#Else
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileW" _
            (ByVal lpFileName As Long, _
            lpFindFileData As WIN32_FIND_DATA) As Long
#End If

Rem 先頭ファイル検索
#If VBA7 Then
Rem http://tokovalue.jp/function/FindFirstFileEx.htm
Rem https://docs.microsoft.com/ja-jp/windows/desktop/api/fileapi/nf-fileapi-findfirstfileexw
Private Declare PtrSafe Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExW" _
            (ByVal lpFileName As LongPtr, _
            ByVal fInfoLevelId As FINDEX_INFO_LEVELS, _
            lpFindFileData As WIN32_FIND_DATA, _
            ByVal fSearchOp As FINDEX_SEARCH_OPS, _
            ByVal lpSearchFilter As LongPtr, _
            ByVal dwAdditionalFlags As Long) As LongPtr
#Else
Private Declare Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExW" _
            (ByVal lpFileName As Long, _
            ByVal fInfoLevelId As FINDEX_INFO_LEVELS, _
            lpFindFileData As WIN32_FIND_DATA, _
            ByVal fSearchOp As FINDEX_SEARCH_OPS, _
            ByVal lpSearchFilter As Long, _
            ByVal dwAdditionalFlags As Long) As Long
#End If

Rem FindFirstFileExについて
Rem https://blogs.yahoo.co.jp/nobuyuki_tsukasa/1059830.html
Rem https://kkamegawa.hatenablog.jp/entry/20100918/p1
Rem 「8.3形式の短いファイル名を生成させない」ことで、「81%くらいに高速化される」事例があった

Rem 　LPCTSTR lpFileName,　　　　　　　// 検索するファイル名
Rem 　FINDEX_INFO_LEVELS fInfoLevelId, // データの情報レベル
Rem 　LPVOID lpFindFileData,　　　　　 // 返された情報へのポインタ
Rem 　FINDEX_SEARCH_OPS fSearchOp,　　 // 実行するフィルタ処理のタイプ
Rem 　LPVOID lpSearchFilter,　　　　　 // 検索条件へのポインタ
Rem 　DWORD dwAdditionalFlags　　　　　// 補足的な検索制御フラグ

Rem https://docs.microsoft.com/ja-jp/windows/desktop/api/minwinbase/ne-minwinbase-findex_info_levels
Private Enum FINDEX_INFO_LEVELS
    FindExInfoStandard = 0&
    Rem FindFirstFile と同じ動作｡
    
    FindExInfoBasic = 1&
    Rem WIN32_FIND_DATAのcAlternateFileNameに短いファイル名を取得しない。
    Rem Windows Server 2008、Windows Vista、Windows Server 2003、Windows XP ではサポートされていない。
    Rem Windows Server 2008 R2 と Windows 7 では使用可能。
    
    FindExInfoMaxInfoLevel = 2&
    'この値は検証に使用されます。 サポートされている値はこの値よりも小さいです。
End Enum

Rem FINDEX_SEARCH_OPS列挙体
Rem fSearchOp : ワイルドカードとの照合以外のフィルタ処理タイプを表す
Private Enum FINDEX_SEARCH_OPS
    FindExSearchNameMatch = 0&
    Rem 指定したファイル名と一致するファイルを検索します。
    Rem この検索操作を使用するときは､FindFirstFileExのlpSearchFilterパラメータをNULLにする必要があります｡
    
    FindExSearchLimitToDirectories = 1&
    Rem ファイルシステムがディレクトリフィルタリングをサポートしている場合、ディレクトリを検索します。
    Rem 実際にはサポートしているファイルシステムは存在せず?効果がないとの事。
    Rem https://gist.github.com/kumatti1/33182de4efe99259e275
    Rem http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=58244;id=excel
    
    FindExSearchLimitToDevices = 2&
    Rem このフィルタリングタイプは利用できません。
    
    FindExSearchMaxSearchOp = 3&
    Rem サポートされていません。
End Enum

Rem dwAdditionalFlags
Private Const FIND_FIRST_EX_CASE_SENSITIVE = 1&
Rem 検索では大文字と小文字が区別されます。

Private Const FIND_FIRST_EX_LARGE_FETCH = 2&
Rem ディレクトリー照会にはより大きなバッファーを使用します。
Rem これにより、検索操作のパフォーマンスが向上する可能性があります。
Rem Windows Server 2008、Windows Vista、Windows Server 2003、およびWindows XP：
Rem この値は、Windows Server 2008 R2およびWindows 7まではサポートされていません。

Private Const FIND_FIRST_EX_ON_DISK_ENTRIES_ONLY = 4&
Rem 結果を物理的にディスク上にあるファイルに制限します。
Rem このフラグは、ファイル仮想化フィルタが存在する場合にのみ関係します。

Rem 次ファイル検索
Rem http://chokuto.ifdef.jp/urawaza/api/FindNextFile.html
#If VBA7 Then
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileW" _
            (ByVal hFindFile As LongPtr, lpFindFileData As WIN32_FIND_DATA) As LongPtr
#Else
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileW" _
            (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
#End If
            
Rem 検索ハンドル開放
Rem http://chokuto.ifdef.jp/urawaza/api/FindClose.html
#If VBA7 Then
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As LongPtr
#Else
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
#End If

Rem ----------------------------------------------------------------------------------------------------

Rem FILETIME構造体
Rem http://chokuto.ifdef.jp/urawaza/struct/FILETIME.html
Private Type FileTime
     LowDateTime As Long
     HighDateTime As Long
End Type

Rem WIN32_FIND_DATA構造体
Rem http://chokuto.ifdef.jp/urawaza/struct/WIN32_FIND_DATA.html
Private Type WIN32_FIND_DATA
    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(260 * 2 - 1)                  As Byte     ' ファイル名
    cAlternateFileName(14 * 2 - 1)          As Byte     ' 8.3形式のファイル名
Rem     cFileName                               As String * MAX_PATH    Rem という書き方もできる。
Rem     cAlternateFileName                      As String * 14          Rem という書き方もできる。
End Type
Rem ※Unicode対応の為*2している

Rem StrCmpLogicalW関数
'エクスプローラのファイル順に並び替える
Rem https://docs.microsoft.com/en-us/windows/desktop/api/shlwapi/nf-shlwapi-strcmplogicalw
Private Declare PtrSafe Function StrCmpLogicalW Lib "SHLWAPI.DLL" _
                (ByVal lpStr1 As String, ByVal lpStr2 As String) As Long


Rem *******************************************************************************
Rem 指定フォルダ以下の任意の階層のファイル・フォルダをリストアップする関数
Rem *******************************************************************************
Rem パラメータ    : 既定値  :  概要  : 意味
Rem parentFolder :     -   :  必須  : 検索対象フォルダの末尾が\で終わるパス
Rem AddFile      :  False  : 省略可 : ファイルを対象に含めるか
Rem AddFolder    :  False  : 省略可 : フォルダを対象に含めるか
Rem SubMin       :      0  : 省略可 : 何階層以降を探索するか（0～n、-1の時は無制限）
Rem SubMax       :      0  : 省略可 : 何階層以前を探索するか（0～n、-1の時は無制限）
Rem SubFolder    :     ""  : 再帰用 : 当初のルートフォルダ以降のパス
Rem SubCount     :      0  : 再帰用 : 現在何階層目か
Rem PathList     : Nothing : 再帰用 : パスリスト。最終的な戻り値
Public Function GetFileFolderList(ByVal parentFolder As String, _
                                    Optional ByVal AddFile = False, _
                                    Optional ByVal AddFolder = False, _
                                    Optional ByVal SubMin As Long = 0, _
                                    Optional ByVal SubMax As Long = 0, _
                                    Optional ByVal SubFolder As String = "", _
                                    Optional ByVal SubCount As Long = 0, _
                                    Optional ByRef PathList As Collection = Nothing _
                                    ) As Collection
    
    Rem 関数突入時の初期化処理
    If PathList Is Nothing Then
        Set PathList = New Collection
        
        If Len(parentFolder) > 0 Then
            If Right(parentFolder, 1) <> "\" Then
                Err.Raise 9999, "GetFileFolderList", "パスの末尾は\で終わるようにしてください。"
            End If
        End If
    End If
    
    Dim ResFolder As Collection: Set ResFolder = New Collection
    Dim ResFile As Collection: Set ResFile = New Collection
    Dim findData As WIN32_FIND_DATA
    
    Rem FindFirstFileW関数では、検索パスの先頭に "\?\"や"\?\UNC" を追加しておくと
    Rem 260 (MAX_PATH) 文字よりも長い文字をパスに指定することが出来る
    Dim UnicodeFolderPath As String
    If parentFolder Like "\\*" Then
        UnicodeFolderPath = "\\?\UNC" & Mid$(parentFolder, 2)
    Else
        UnicodeFolderPath = "\\?\" & parentFolder
    End If
    
    Rem 検索ハンドルが見つからない場合は「INVALID_HANDLE_VALUE」を返す
#If VBA7 Then
    Dim fileHandle As LongPtr
#Else
    Dim fileHandle As Long
#End If
    If USE_FindFirstFileEx Then
        Rem ※FindExInfoBasic/FIND_FIRST_EX_LARGE_FETCH指定により高速化を実現
        fileHandle = FindFirstFileEx(StrPtr(UnicodeFolderPath & "*"), FindExInfoBasic, _
                                findData, FindExSearchNameMatch, 0&, FIND_FIRST_EX_LARGE_FETCH)
    End If
    
    If Not USE_FindFirstFileEx Or fileHandle = INVALID_HANDLE_VALUE Then
        fileHandle = FindFirstFile(StrPtr(UnicodeFolderPath & "*"), findData)
    End If
    
    If fileHandle = INVALID_HANDLE_VALUE Then
        Exit Function
    End If
    
    Do
        Rem FindFirstFileではファイル名の後ろに「Max_Path」で指定した文字数までNullが詰まっている。
        Dim intStLen As Long
        intStLen = InStr(findData.cFileName, vbNullChar) - 1
        If intStLen > 0 Then
            Dim sFilename As String
            sFilename = Trim$(Left$(findData.cFileName, intStLen))
            
            Rem カレントフォルダ以外か上位フォルダ
            If sFilename = "." Or sFilename = ".." Then
                
            Rem フォルダ予約
            ElseIf findData.dwFileAttributes And vbDirectory Then
                ResFolder.Add sFilename
            Rem ファイル予約
            Else
                If AddFile And (SubMin = -1 Or SubMin <= SubCount) Then
                    Rem ※ファイルはルートパスを除いた相対パス
                    ResFile.Add SubFolder & sFilename
                End If
            End If
        End If
        Rem 次のファイルが見つからなかった場合は0を返すためループ終了
    Loop Until FindNextFile(fileHandle, findData) = 0
    
    Rem 検索ハンドルを閉じる
    FindClose fileHandle
    
    Rem ファイルリストをソートしてから追加
    'CollectionSort_StrCmpLogicalW ResFile
    
    Dim myFile As Variant
    For Each myFile In ResFile
        PathList.Add myFile
    Next
    
    Rem フォルダリストをソートしてから追加して、再帰探索へ
    'CollectionSort_StrCmpLogicalW ResFolder
    
    Dim myFolder As Variant
    For Each myFolder In ResFolder
        Rem フォルダ追加
        If AddFolder Then
            Rem ※フォルダはルートパスを除いた相対パスで末尾は "\"
            PathList.Add SubFolder & myFolder & "\"
        End If
        Rem サブフォルダ再帰探索
        If SubCount < SubMax Or SubMax = -1 Then
            Call GetFileFolderList(parentFolder & myFolder & "\", AddFile, AddFolder, SubMin, SubMax, _
                                    SubFolder & myFolder & "\", SubCount + 1, PathList)
        End If
    Next
    
    Set GetFileFolderList = PathList
    
End Function

'Colection入れ替え
Private Sub CollectionSwap(C As Collection, Index1 As Long, Index2 As Long)
    Dim Item1 As Variant, Item2 As Variant
    Item1 = C.Item(Index1)
    Item2 = C.Item(Index2)
    
    C.Add Item1, After:=Index2
    C.Remove Index2
    C.Add Item2, After:=Index1
    C.Remove Index1
End Sub

'CollectionをStrCmpLogicalWでソート
Private Sub CollectionSort_StrCmpLogicalW(C As Collection)
    Dim i As Long, j As Long
    For i = 1 To C.Count
        For j = C.Count To i Step -1
            If StrCmpLogicalW(StrConv(C(i), vbUnicode), _
                              StrConv(C(j), vbUnicode)) > 0 Then
                CollectionSwap C, i, j
            End If
        Next
    Next
End Sub

検証用モジュール

下記のTest_GetFileList_API_Kotoriを実行すると、API_Kotoriシートが追加されてそこにファイルリストが出力されます。

既存のシートは破壊しないので安心して実行していただけます。

▶ソースコードを展開（前回の記事と同じ部分）

'Public Const SEARCH_PATH = "C:\"
'Public Const SEARCH_PATH = "C:\Windows\"
'Public Const SEARCH_PATH = "C:\Test\Sort\"
Rem テスト用コード
Sub Test_GetFileList_API_Kotori()
    
    Dim tStart As Single, tStop As Single: tStart = Timer
    

    Dim colPaths As Collection
    Set colPaths = GetFileFolderList(SEARCH_PATH, True, True, -1, -1)
    
    tStop = Timer: Debug.Print Format$(tStop - tStart, "0.00") & " sec."
    
    Call OutputCollection(colPaths, "API_Kotori")

End Sub

'指定した名前のシートにコレクションの内容を書き出し
Public Sub OutputCollection(col As Collection, SheetName As String)
    
    If col Is Nothing Then Exit Sub
    If col.Count = 0 Then Exit Sub
    

    'シート準備
    Dim WS As Worksheet
    If SheetExists(SheetName) Then
        Set WS = ThisWorkbook.Worksheets(SheetName)
    Else
        Set WS = ThisWorkbook.Worksheets.Add
        WS.Name = SheetName
    End If
    WS.Cells.Clear
    
    'コレクションの二次元配列化
    Dim i As Long
    Dim Item As Variant
    Dim Data As Variant
    
    ReDim Data(1 To WorksheetFunction.Min(1000000, col.Count), _
               1 To WorksheetFunction.RoundUp(col.Count / 1000000, 0))
    
    i = 0
    For Each Item In col
        Data(1 + (i Mod 1000000), 1 + Int(i / 1000000)) = Item
        i = i + 1
    Next
    
    'シートへの出力
    WS.Cells(1, 1).Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data

End Sub

'指定したシートが存在するか確認する。
Public Function SheetExists(SheetName As String, Optional Wb As Workbook) As Boolean
    If Wb Is Nothing Then
        If ThisWorkbook.IsAddin Then
            Set Wb = ActiveWorkbook
        Else
            Set Wb = ThisWorkbook
        End If
    End If
    

    On Error Resume Next
    Dim Dummy As Worksheet
    Set Dummy = Wb.Worksheets(Left(SheetName, 31))
    On Error GoTo 0
    
    SheetExists = Not (Dummy Is Nothing)
End Function

ソートテストのための下準備用の関数（任意）

Rem ソートテスト用ファイル生成
Public Sub Test_FileCreate()
    Dim fso As FileSystemObject: Set fso = New FileSystemObject
    Dim Arr As Variant
    Arr = VBA.Array("X10Y1", "X10Y10", "X10Y2", "X1Y1", _
                    "X1Y10", "X1Y2", "X2Y1", "X2Y10", "X2Y2")
    Dim Fol As String
    Fol = "C:\Test\Sort\"
    On Error Resume Next
    fso.createFolder Fol
    On Error GoTo 0
    
    Dim i As Long
    For i = LBound(Arr) To UBound(Arr)
        fso.CreateTextFile Fol & Arr(i)
    Next
End Sub

一応こんな感じでソートされるのを確認しました。

Before	After
X10Y1	X1Y1
X10Y10	X1Y2
X10Y2	X1Y10
X1Y1	X2Y1
X1Y10	X2Y2
X1Y2	X2Y10
X2Y1	X10Y1
X2Y10	X10Y2
X2Y2	X10Y10

検証結果

FindFirstFileEx関数導入後

まずはソート機能を追加する前ですが、このような結果になりました。

参考にした記事と同じで80%前後の高速化ができています。

媒体/パス	File	Folder	試行回数	FindFirstFile	FindFirstFileEx	高速化率
SSD C:\Windows\	149369	32303	1	7.59	6.13	81%
SSD D:\	82213	441	50	7.52	6.64	88%
USBメモリ	62200	310	50	6.45	5.66	88%
NAS	65600	5846	1	29.18	21.23	73%

StrCmpLogicalW関数ソート導入後

コレクションのソート関数が重すぎるようで、完全に失敗しました。

原因はアイテムをインデックスで指定しているからですね。

でもインデックス指定じゃないとSwap出来ない気がします。

一旦配列変数に変換して処理するくらいしか今の所思いつきません。

とりあえず今回は断念しました。

なお、本記事のGetFileFolderList関数の仕様や解説については、前の記事で説明しておりますので必要な場合はこちらを参照願います。

www.excel-chunchun.com

おわりに

前回の関数から次の点が改良されました。

• 64bit版Officeに対応
• APIを変更して高速化(Windows7以降)

しかしファイルリストのソートは解決できませんでした。

ファイルリスト作成の旅は、もう少しだけ続きそうです。

---

何か御座いましたらコメント欄、またはTwitterからどうぞ♪

それではまた明日♪　ちゅんちゅん(・8・)