HOME > エクセルVBA > サンプル > FindFirstFileEx

FindFirstFileEx


【ファイル名】FindFirstFileEx.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年06月01日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】FindFirstFileEx.zip
【説明】Windows APIのFindFirstFileExW、FindNextFileW関数でファイルの一覧を作成します。
【注意】このサンプルはファイル サイズに誤差があり、エクスプローラーと異なります。(Decimal型を使用したため)
画面

【外部リンク】Windows > Apps > Win32 > API > Data Access and Storage > Fileapi.h >  FindFirstFileExW functionFindNextFileW functionFindClose function
【外部リンク】Windows > Apps > Win32 > API > Data Access and Storage > Minwinbase.h >  FINDEX_INFO_LEVELS enumerationFINDEX_SEARCH_OPS enumerationWIN32_FIND_DATAW structure
【外部リンク】Windows > Apps > Win32 > API > Minwinbase.h >  FILETIME structureSYSTEMTIME structure
【外部リンク】Windows > Apps > Win32 > API >  Timezoneapi.h >  TIME_ZONE_INFORMATION structureFileTimeToSystemTime functionGetTimeZoneInformation functionSystemTimeToTzSpecificLocalTime function

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="FindFirstFileEx">
          <box id="Box1" boxStyle="vertical">
            <editBox id="editBox1" label="検索パス名:" keytip="N" maxLength="1024" getText="getText" onChange="onChange"
                     supertip="検索パスを入力して、Enter キーを押してください。"
                     sizeString="WWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMM" />
            <button id="SearchPathButton" label="検索" keytip="F" imageMso="HappyFace"
                    supertip="ファイルの一覧を作成します。" onAction="onAction" />
            <labelControl id="labelControl1" label="「*」は0文字以上、「?」は0あるいは1文字に一致します。" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

Module1
Option Explicit

Private Const MAX_PATH = 260& ' パスの最大文字数
Private Const INVALID_HANDLE_VALUE = (-1) ' FindFirstFileEx関数のエラーの戻り値

' WinNT.h
Private Const FILE_ATTRIBUTE_READONLY = &H1   ' 読み取り専用ファイル属性
Private Const FILE_ATTRIBUTE_HIDDEN = &H2     ' 隠しファイル属性
Private Const FILE_ATTRIBUTE_SYSTEM = &H4     ' システムファイル属性
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10 ' ディレクトリ属性
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20   ' アーカイブファイル属性
'Private Const FILE_ATTRIBUTE_DEVICE = &H40
'Private Const FILE_ATTRIBUTE_NORMAL = &H80
'Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
'Private Const FILE_ATTRIBUTE_SPARSE_FILE = &H200
'Private Const FILE_ATTRIBUTE_REPARSE_POINT = &H400
'Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const FILE_ATTRIBUTE_OFFLINE = &H1000 ' オフライン属性
Private Const FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = &H2000 ' 非インデックス対象ファイル属性
'Private Const FILE_ATTRIBUTE_ENCRYPTED = &H4000
'Private Const FILE_ATTRIBUTE_INTEGRITY_STREAM = &H8000
'Private Const FILE_ATTRIBUTE_VIRTUAL = &H10000
'Private Const FILE_ATTRIBUTE_NO_SCRUB_DATA = &H20000
'Private Const FILE_ATTRIBUTE_EA = &H40000
'Private Const FILE_ATTRIBUTE_PINNED = &H80000
'Private Const FILE_ATTRIBUTE_UNPINNED = &H100000
'Private Const FILE_ATTRIBUTE_RECALL_ON_OPEN = &H40000
'Private Const FILE_ATTRIBUTE_RECALL_ON_DATA_ACCESS = &H400000

' FindFirstFileEx関数の引数のdwAdditionalFlags
Private Const FIND_FIRST_EX_CASE_SENSITIVE = 1& ' 大文字と小文字を区別して検索する
Private Const FIND_FIRST_EX_LARGE_FETCH = 2&    ' 大きいバッファで高速化する
Private Const FIND_FIRST_EX_ON_DISK_ENTRIES_ONLY = 4& ' 物理的ディスクのみ

' FindFirstFileEx関数の引数のfInfoLevelId
' https://docs.microsoft.com/en-us/windows/win32/api/minwinbase/ne-minwinbase-findex_info_levels
Enum FINDEX_INFO_LEVELS ' minwinbase.h
  FindExInfoStandard     ' Dos(8.3形式)のファイル名を取得する
  FindExInfoBasic        ' Dos(8.3形式)のファイル名を取得しないで高速化
  FindExInfoMaxInfoLevel ' 検証用?
End Enum

' FindFirstFileEx関数の引数のfSearchOp
' https://docs.microsoft.com/en-us/windows/win32/api/minwinbase/ne-minwinbase-findex_search_ops
Enum FINDEX_SEARCH_OPS ' minwinbase.h
  FindExSearchNameMatch
  FindExSearchLimitToDirectories
  FindExSearchLimitToDevices
  FindExSearchMaxSearchOp
End Enum

' https://docs.microsoft.com/en-us/windows/win32/api/minwinbase/ns-minwinbase-filetime
Type FILETIME ' minwinbase.h
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

' https://docs.microsoft.com/en-us/windows/win32/api/minwinbase/ns-minwinbase-systemtime
Type SYSTEMTIME ' minwinbase.h
  wYear As Integer
  wMonth As Integer
  wDayOfWeek As Integer
  wDay As Integer
  wHour As Integer
  wMinute As Integer
  wSecond As Integer
  wMilliseconds As Integer
End Type

' https://docs.microsoft.com/en-us/windows/win32/api/timezoneapi/ns-timezoneapi-time_zone_information
Type TIME_ZONE_INFORMATION ' timezoneapi.h
  Bias As Long
  StandardName(0 To 31) As Integer
  StandardDate As SYSTEMTIME
  StandardBias As Long
  DaylightName(0 To 31) As Integer
  DaylightDate As SYSTEMTIME
  DaylightBias As Long
End Type

' https://docs.microsoft.com/en-us/windows/win32/api/minwinbase/ns-minwinbase-win32_find_dataw
Type WIN32_FIND_DATAW ' minwinbase.h
  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(1 To MAX_PATH * 2) As Byte ' ファイル名 ユニコードは1文字につき2バイト必要
  cAlternate(1 To 14 * 2) As Byte      ' Dosのファイル名(8.3形式) ユニコードは1文字につき2バイト必要
  dwFileType       As Long    ' Macintosh用なので使用されないと思います。Win32API_PtrSafe.TXTではありません。
  dwCreatorType    As Long    '  同上
  wFinderFlags     As Integer '  同上
End Type

#If Win64 Then
  ' https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-findfirstfileexw
  ' LPCTSTR lpFileName,       ' 検索するパス名
  ' FINDEX_INFO_LEVELS fInfoLevelId, ' 情報レベル
  ' LPVOID lpFindFileData,      ' 取得したファイル情報
  ' FINDEX_SEARCH_OPS fSearchOp,   ' 検索のフィルタのオプション
  ' LPVOID lpSearchFilter,      ' 検索条件のポインタ
  ' DWORD dwAdditionalFlags     ' 補足的なフラグ
  '  戻り値 成功は検索のハンドル、失敗は INVALID_HANDLE_VALUE を返します。
  Private Declare PtrSafe Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExW" ( _
                                                                        ByVal lpFileName As LongPtr, _
                                                                        ByVal fInfoLevelId As Long, _
                                                                        lpFindFileData As WIN32_FIND_DATAW, _
                                                                        ByVal fSearchOp As Long, _
                                                                        ByVal lpSearchFilter As Long, _
                                                                        ByVal dwAdditionalFlags As Long) As LongPtr
                                                                        
  ' https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-findnextfilew
  Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileW" (ByVal hFindFile As LongPtr, lpFindFileData As WIN32_FIND_DATAW) As Long
  
  ' https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-findclose
  Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As Long

  ' https://docs.microsoft.com/en-us/windows/win32/api/timezoneapi/nf-timezoneapi-filetimetosystemtime
  Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long

  ' https://docs.microsoft.com/ja-jp/windows/win32/api/timezoneapi/nf-timezoneapi-gettimezoneinformation
  Private Declare PtrSafe Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long

  ' https://docs.microsoft.com/ja-jp/windows/win32/api/timezoneapi/nf-timezoneapi-systemtimetotzspecificlocaltime
  Private Declare PtrSafe Function SystemTimeToTzSpecificLocalTime Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION, lpUniversalTime As SYSTEMTIME, lpLocalTime As SYSTEMTIME) As Long

#Else
  Private Declare Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExW" ( _
                                                                        ByVal lpFileName As Long, _
                                                                        ByVal fInfoLevelId As Long, _
                                                                        lpFindFileData As WIN32_FIND_DATAW, _
                                                                        ByVal fSearchOp As Long, _
                                                                        ByVal lpSearchFilter As Long, _
                                                                        ByVal dwAdditionalFlags As Long) As Long

  Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileW" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATAW) As Long
  Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
  Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
  Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
  Private Declare Function SystemTimeToTzSpecificLocalTime Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION, lpUniversalTime As SYSTEMTIME, lpLocalTime As SYSTEMTIME) As Long
#End If

Private rbRibbonUI As IRibbonUI   ' リボン
Private rbText As String ' editBoxの文字列

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbText = ".\*.*"
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

 ' ファイル一覧を作成する
Sub createFileList(Optional PathMask As String = "*.*")
  Dim row As Long
  Dim Ret As Long
  Dim Size As Variant ' ファイル サイズ
  Dim fn As String ' ファイル名
  Dim ws As Worksheet
  Dim WFD As WIN32_FIND_DATAW
#If Win64 Then
  Dim hFindFile As LongPtr ' 検索用のハンドル
#Else
  Dim hFindFile As Long
#End If

  hFindFile = FindFirstFileEx(StrPtr(PathMask & vbNullChar), FINDEX_INFO_LEVELS.FindExInfoBasic, WFD, _
                              FINDEX_SEARCH_OPS.FindExSearchNameMatch, 0&, FIND_FIRST_EX_LARGE_FETCH)
  If hFindFile = INVALID_HANDLE_VALUE Then
    MsgBox prompt:="検索と一致するファイルが見つかりませんでした。", Buttons:=vbExclamation + vbSystemModal, Title:="警告"
    Exit Sub
  End If
  
  Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)) ' ワークシートを新規作成する
  Dim header As Variant
  header = Array("ファイル名", "作成日", "最終アクセス日", "最終更新日", "ファイルサイズ", "属性")
  ws.Range("A1:F1").Value = header
  row = 1
  Do
    fn = StrVBA(WFD.cFileName)
    If fn <> "." And fn <> ".." Then ' カレントと親のディレクトリは除く
      row = row + 1 ' 最大行(1,048,576)を超えたらエラーになります。
      ws.Cells(row, 1).Value = fn ' ファイル名
      ws.Cells(row, 2).NumberFormatLocal = "_ yyyy/mm/dd_ hh:MM_ "
      ws.Cells(row, 2).Value = getFileTimeText(WFD.ftCreationTime)   ' 作成日
      ws.Cells(row, 3).NumberFormatLocal = "_ yyyy/mm/dd_ hh:MM_ "
      ws.Cells(row, 3).Value = getFileTimeText(WFD.ftLastAccessTime) ' 最終アクセス日
      ws.Cells(row, 4).NumberFormatLocal = "_ yyyy/mm/dd_ hh:MM_ "
      ws.Cells(row, 4).Value = getFileTimeText(WFD.ftLastWriteTime)  ' 最終更新日
      ws.Cells(row, 5).NumberFormatLocal = "#,##0_ "
      ' ファイルサイズ
      Size = CDec(WFD.nFileSizeHigh)
      If Size < 0 Then
        Size = Size + CCur(4294967296#) ' マイナスの値をプラスに変換する
      End If
      Size = Size * 2 ^ 32 ' 左へ32ビット シフトする
      If WFD.nFileSizeLow < 0 Then
        Size = Size + WFD.nFileSizeLow + CCur(4294967296#) ' マイナスの値をプラスに変換する
      Else
        Size = Size + WFD.nFileSizeLow
      End If
      ws.Cells(row, 5).Value = Format(Size / 1024, "0") ' 四捨五入する(エクスプローラとは同じ値になりません?)
      
      ws.Cells(row, 6).Value = getFileAttributes(WFD.dwFileAttributes) ' 属性
    End If
    
    If (row Mod 500) = 0 Then
      DoEvents ' 他のプログラムを実行できるようにする。
      Application.StatusBar = "実行中です。しばらくお待ちください..." & CStr(row) ' ステータスバーにメッセージを表示
    End If
    
    Ret = FindNextFile(hFindFile, WFD)
  Loop While Ret <> 0
  FindClose hFindFile ' 検索用のハンドルを閉じる
    
  Application.StatusBar = "テーブルを作成しています。"  ' ステータスバーにメッセージを表示
  With ws ' テーブルの作成
    .Range("A1").Select
    Selection.CurrentRegion.Select
    .ListObjects.Add(xlSrcRange, ActiveWindow.RangeSelection, , xlYes).TableStyle = "TableStyleMedium1"
    .Columns("A:F").EntireColumn.AutoFit ' 列の幅を自動調整
    .Range("A1").Select
  End With
End Sub

' システム日付の文字列を取得する
Private Function getFileTimeText(lpFileTime As FILETIME) As String
  Dim lpUniversalTime As SYSTEMTIME
  Dim lpLocalTime As SYSTEMTIME
  Dim TZI As TIME_ZONE_INFORMATION

  FileTimeToSystemTime lpFileTime, lpUniversalTime
  GetTimeZoneInformation TZI
  SystemTimeToTzSpecificLocalTime TZI, lpUniversalTime, lpLocalTime
  getFileTimeText = Format(lpLocalTime.wYear, "00") & "/" & Format(lpLocalTime.wMonth, "00") & "/" & Format(lpLocalTime.wDay, "00") & " " & _
                    Format(lpLocalTime.wHour, "00") & ":" & Format(lpLocalTime.wMinute, "00") & ":" & Format(lpLocalTime.wSecond, "00")
End Function

' 属性の文字列を取得する
Private Function getFileAttributes(dwFileAttributes As Long) As String
  Dim s As String
  
  s = ""
  If dwFileAttributes And FILE_ATTRIBUTE_ARCHIVE Then s = s + "A"
  If dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY Then s = s + "D"
  If dwFileAttributes And FILE_ATTRIBUTE_SYSTEM Then s = s + "S"
  If dwFileAttributes And FILE_ATTRIBUTE_HIDDEN Then s = s + "H"
  If dwFileAttributes And FILE_ATTRIBUTE_READONLY Then s = s + "R"
  If dwFileAttributes And FILE_ATTRIBUTE_OFFLINE Then s = s + "O"
  If dwFileAttributes And FILE_ATTRIBUTE_NOT_CONTENT_INDEXED Then s = s + "I"
  getFileAttributes = s
End Function

' 指定したヌルで終わる文字列から、vbNullCharの左側の文字列を取得します。
Private Function StrVBA(ByVal EndNullString As String) As String
  Dim p As Long
  
  p = InStr(1, EndNullString, vbNullChar)
  If p > 0 Then
    StrVBA = Left(EndNullString, p - 1)
  Else
    StrVBA = EndNullString ' ■ vbNullCharがない場合は引数をそのまま返します。
'    StrVBA = vbNullString ' ■ 必要に応じて変更してください。
  End If
End Function

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  Dim tmpCalculation As XlCalculation ' 計算方法のモード
  Dim IsDisplayStatusBar As Boolean ' ステータスバーの表示状態を保存
  Dim Ret As VbMsgBoxResult ' MsgBoxの返値
  Dim IsDisplayPageBreaks As Boolean  ' 改ページの有効・無効
  
  Err.Clear ' エラーをクリアーします。
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "SearchPathButton"
      If Len(rbText) < 1 Then
        MsgBox prompt:="検索パス名を入力してください!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
        Exit Sub
      End If

      On Error GoTo ErrorHandle2 ' ◆ エラー処理ルーチンを有効にします。
      Application.EnableEvents = False ' イベントを無効にします。
      If Not Application.ActiveCell Is Nothing Then
        tmpCalculation = Application.Calculation ' 計算方法のモードを保存
        Application.Calculation = xlCalculationManual ' 計算方法のモードを手動にし、計算しない
        IsDisplayPageBreaks = ActiveSheet.DisplayPageBreaks ' 改ページの有効・無効を保存します。
        ActiveSheet.DisplayPageBreaks = False ' 改ページを無効にします。
      End If
      Application.EnableCancelKey = xlErrorHandler ' ◆ Esc キーを押すとエラーにします。
      IsDisplayStatusBar = Application.DisplayStatusBar ' ステータスバーの表示状態を保存
      Application.StatusBar = "実行中です。しばらくお待ちください..." ' ステータスバーにメッセージを表示
      Application.DisplayStatusBar = True ' ステータスバーを表示
      Application.Cursor = xlWait ' マウスカーソルを砂時計
      Application.ScreenUpdating = False '画面の更新を停止して、ちらつきを防止

  ' 長い処理を開始 --->
      createFileList rbText ' ファイル一覧を作成する
  ' 長い処理を終了 <---

ErrorHandle2: ' 元に戻す処理 (エラーや、[ESC]キーが押された場合のため)
      If Err.Number > 0 Then ' エラー処理
        Ret = MsgBox(prompt:=Err.Description & vbNewLine & vbNewLine & "処理を続けますか?", Buttons:=vbExclamation + vbAbortRetryIgnore, Title:="エラー")
        If Ret = vbRetry Then Resume ' 再試行
        If Ret = vbIgnore Then Resume Next ' 無視
        ' 中止の場合は下の行の処理へ
      End If
      Application.EnableEvents = True ' イベントを有効にします。
      If Not Application.ActiveCell Is Nothing Then
        Application.Calculation = tmpCalculation ' 計算方法のモードを元に戻す
        ActiveSheet.DisplayPageBreaks = IsDisplayPageBreaks ' 改ページを元に戻します。
      End If
      Application.StatusBar = "" ' ステータスバーをを元に戻す
      Application.DisplayStatusBar = IsDisplayStatusBar ' ステータスバーの表示を元に戻す
      Application.Cursor = xlDefault ' マウスカーソルを省略値に戻す
      Application.EnableCancelKey = xlInterrupt ' デバッグ、終了などを行えるように、実行中のプロシージャを停止
      Application.ScreenUpdating = True '画面の更新をする
      
      Exit Sub
    Case Else
      Beep ' 警告音
      MsgBox prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub

Sub getText(control As IRibbonControl, ByRef returnedVal) ' editBoxに文字列を代入する
  returnedVal = rbText
End Sub

Sub onChange(control As IRibbonControl, text As String) ' editBoxで[Enter]キーを押したか、他のコントロールに移動した場合のイベント
  rbText = text
End Sub
このページの上