VBA応用(ファイルの検索)

今度は、所在の分からないファイルを検索してみましょう。

フォルダ内のファイル一覧の取得は以前に紹介しました。フォルダ内のファイル一覧の取得で、配下のサブフォルダを含めたファイルの一覧の作成は紹介しましたから、これを利用して、特定な条件のファイルを探索することに利用できるかも知れません。

ですが、FileSearchオブジェクトを利用すると、再帰処理も書かずに、しかもワイルドカードを使ってファイルの探索ができます。
だったですが、Office 2007以降では、FileSearchオブジェクトそのものが「Office 2007 プログラムのファイルのマクロの検索マクロを実行すると、エラーメッセージ:ランタイムエラー 5111」ということでは正式にサポートされなくなりました。
(以前にこのページになった説明は削除しています)

したがって「再帰処理」は学ぶ必要があるようです。

サンプルでは、ルートフォルダと探索するファイルのキーワード、最終更新日条件を設定します。

シートの上3行にこれらの条件を設定して、マクロの起動で「Sample_FileSearch」を実行して下さい。
FileSearchの代替策にMicrosoftは「Windows Desktop Search」を使うことを勧めているようですが、VBAでどうするのかというと参照設定に出てくるわけでもなく情報がほとんど見つかりません。(「EXPLORER」をShellで起動するような話にも見えます)
と、なると独自に再帰動作するコードを作成しないといけないようです。

(画像をクリックすると、このサンプルがダウンロードできます)
単にFileSystemObjectを使って、フォルダ単位に再帰動作させ、フォルダ単位に存在するファイルを巡回して検索対象かどうかを判断させています。各フォルダの全ファイルを探索して、1ファイルずつファイル名をLike判定で対象かを判断させています。

コードはこのようになりました。


'***************************************************************************************************
'   ファイルの検索(条件に該当するものをシートに表示)                Module1(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 07/08/02(1.0.0)新規作成
' 17/12/02(1.1.0)*.xlsm版で再作成
' 17/12/10(1.1.0)更新日時判定を先に判断してループ内の判断文を回避
' 19/10/28(1.2.0)Declare記述の変更(64ビット版Excel対応)
' 20/02/29(1.2.1)記述整理、他
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "ファイルの検索"
'---------------------------------------------------------------------------------------------------
' GetSystemTimeで使用する構造体
Private Type SYSTEMTIME
    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
'---------------------------------------------------------------------------------------------------
#If VBA7 Then
' ■システム時刻取得
Private Declare PtrSafe Sub GetSystemTime Lib "KERNEL32.dll" (lpSystemTime As SYSTEMTIME)
#Else
' ■システム時刻取得
Private Declare Sub GetSystemTime Lib "KERNEL32.dll" (lpSystemTime As SYSTEMTIME)
#End If
'---------------------------------------------------------------------------------------------------
Private g_strSearchWord As String                               ' 検索文字列
Private g_dteDate As Date                                       ' 更新日付限度
Private g_blnAllDate As Boolean                                 ' 更新日付不問

'***************************************************************************************************
'   ■■■ 起動処理 ■■■
'***************************************************************************************************
'* 処理名　：FileSearchSample2
'* 機能　　：ファイル検索機能サンプル②
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2007年08月02日
'* 作成者　：井上　治
'* 更新日　：2020年02月29日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：※シート上の入力値に対する条理チェック、実行時エラー対応は行なっていません
'***************************************************************************************************
Sub FileSearchSample2()
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngCntSearch As Long                                        ' 検索ファイル数
    Dim lngCntFound As Long                                         ' 発見ファイル数
    Dim objStrTime As SYSTEMTIME                                    ' 開始日時
    Dim objEndTime As SYSTEMTIME                                    ' 終了日時
    Dim strMSG As String                                            ' メッセージ
    '-----------------------------------------------------------------
    Set objFso = New FileSystemObject
    Rows("5:" & Rows.Count).ClearContents
    lngRow = 4
    ' 指定値セット
    g_strSearchWord = UCase(Trim(Cells(2, 2).Value))
    If Cells(3, 2).Value <> "" Then
        g_dteDate = DateAdd("m", Cells(3, 2).Value * -1, Date)
        g_blnAllDate = False
    Else
        g_blnAllDate = True
    End If
    ' 画面描画停止
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    ' 開始日時取得
    Call GetSystemTime(objStrTime)
    '-----------------------------------------------------------------
    ' ルートフォルダから探索開始(フォルダ単位処理)
    Call GP_FolderProc(objFso, _
                       objFso.GetFolder(Trim(Cells(1, 2).Value)), _
                       lngRow, _
                       lngCntSearch)
    '-----------------------------------------------------------------
    ' 終了日時取得
    Call GetSystemTime(objEndTime)
    Set objFso = Nothing
    ' 画面描画再開
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    lngCntFound = lngRow - 4
    ' 処理結果の表示
    If lngCntFound = 0 Then
        strMSG = "見つかりません"
    Else
        strMSG = lngCntFound & "個見つかりました"
    End If
    strMSG = strMSG & vbCrLf & "検索件数=" & lngCntSearch & "ファイル"
    strMSG = strMSG & vbCrLf & "発見件数=" & lngCntFound & "ファイル"
    strMSG = strMSG & vbCrLf & "処理時間=" & FP_SumProcSec(objStrTime, objEndTime) & "秒"
    MsgBox strMSG, vbInformation, g_cnsTitle
End Sub

'***************************************************************************************************
'* 処理名　：GP_FolderProc
'* 機能　　：フォルダ単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = FileSystemObject(Object)
'* 　　　　　Arg2 = Folder(Object)
'* 　　　　　Arg3 = 行INDEX(Long)                       ※Ref参照
'* 　　　　　Arg4 = 検索ファイル数(Long)                ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2007年08月02日
'* 作成者　：井上　治
'* 更新日　：2020年02月29日
'* 更新者　：井上　治
'* 機能説明：本処理は再帰動作となります
'* 注意事項：※エラー処置無し(サンプルなので)
'***************************************************************************************************
Private Sub GP_FolderProc(ByRef objFso As FileSystemObject, _
                          ByVal objFolder As Folder, _
                          ByRef lngRow As Long, _
                          ByRef lngCntSearch As Long)
    '-----------------------------------------------------------------------------------------------
    Dim objSubFolder As Folder                                      ' サブフォルダ
    Dim objFile As File                                             ' ファイル
    Dim strFileU As String                                          ' ファイル名
    Dim strPath As String                                           ' フォルダ名
    '-----------------------------------------------------------------
    ' ■サブフォルダの探索
    For Each objSubFolder In objFolder.SubFolders
        ' フォルダ単位処理(再帰動作)
        Call GP_FolderProc(objFso, objSubFolder, lngRow, lngCntSearch)
    Next objSubFolder
    '-----------------------------------------------------------------
    ' ■本フォルダ内の各ファイルの探索
    ' 更新日時判定使用かどうかで分離(不要な判断を避けるため)
    If Not g_blnAllDate Then
        ' このフォルダ内のファイルの探索
        For Each objFile In objFolder.Files
            lngCntSearch = lngCntSearch + 1
            strFileU = UCase(objFile.Name)
            ' LIKE判定
            If strFileU Like g_strSearchWord Then
                ' 更新日時判定
                If objFile.DateLastModified >= g_dteDate Then
                    ' 該当ならシートの表示
                    With objFile
                        strPath = Left(.Path, Len(.Path) - Len(.Name) - 1)
                        lngRow = lngRow + 1
                        Cells(lngRow, 1).Value = .Name
                        Cells(lngRow, 2).Value = .DateLastModified
                        Cells(lngRow, 3).Value = strPath
                    End With
                End If
            End If
        Next objFile
    Else
        ' このフォルダ内のファイルの探索
        For Each objFile In objFolder.Files
            lngCntSearch = lngCntSearch + 1
            strFileU = UCase(objFile.Name)
            ' LIKE判定
            If strFileU Like g_strSearchWord Then
                ' 該当ならシートの表示
                With objFile
                    strPath = Left(.Path, Len(.Path) - Len(.Name) - 1)
                    lngRow = lngRow + 1
                    Cells(lngRow, 1).Value = .Name
                    Cells(lngRow, 2).Value = .DateLastModified
                    Cells(lngRow, 3).Value = strPath
                End With
            End If
        Next objFile
    End If
End Sub

'***************************************************************************************************
'* 処理名　：FP_SumProcSec
'* 機能　　：処理秒数の算出
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理秒数(Double)
'* 引数　　：Arg1 = 開始日時(SYSTEMTIME)
'* 　　　　　Arg2 = 終了日時(SYSTEMTIME)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年12月02日
'* 作成者　：井上　治
'* 更新日　：2017年12月02日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：終了日時≧開始日時であること、開始：終了間で日付が変わるケースは同月内のみ対応
'***************************************************************************************************
Private Function FP_SumProcSec(ByRef objStrTime As SYSTEMTIME, _
                               ByRef objEndTime As SYSTEMTIME) As Double
    '-----------------------------------------------------------------------------------------------
    Const cnsSecByDate As Double = 86400                            ' 1日の秒数
    Const cnsSecByHour As Double = 3600                             ' 1時間の秒数
    Const cnsSecByMinute As Double = 60                             ' 1分の秒数
    Dim dblStrTime As Double                                        ' 開始日時(シリアル値)
    Dim dblEndTime As Double                                        ' 終了日時(シリアル値)
    '-----------------------------------------------------------------
    ' 開始日時(シリアル値)
    With objStrTime
        dblStrTime = .wDay * cnsSecByDate
        dblStrTime = dblStrTime + .wHour * cnsSecByHour
        dblStrTime = dblStrTime + .wMinute * cnsSecByMinute
        dblStrTime = dblStrTime + .wSecond
        dblStrTime = dblStrTime + .wMilliseconds / 1000
    End With
    '-----------------------------------------------------------------
    ' 終了時刻(シリアル値)
    With objEndTime
        dblEndTime = .wDay * cnsSecByDate
        dblEndTime = dblEndTime + .wHour * cnsSecByHour
        dblEndTime = dblEndTime + .wMinute * cnsSecByMinute
        dblEndTime = dblEndTime + .wSecond
        dblEndTime = dblEndTime + .wMilliseconds / 1000
    End With
    FP_SumProcSec = dblEndTime - dblStrTime
End Function

'------------------------------------------<< End of Source >>--------------------------------------

FileSearchと異なり、この方法は指定フォルダ配下(サブフォルダ含む)の全ファイルを検索しながら、このソースコードの記述でファイル名の「LIKE判定」で探索対象かを判断しています。

結果は上記の方法で得られるのですが．．．．

再帰動作のプログラムを作成すれば、確かに上記の結果は得られます。
しかし、特に大量なファイル数の中からごく少数のファイルを検索するようなケースだとFileSearchに比べてかなり遅いようです。指定フォルダ配下の全ファイルをプログラム側で順次検索して検索対象かを判断する方法なので、FileSearchのようにそもそも最初から検索対象を絞り込める方法とは異なります。
実際に質問をいただいたのですが、当方でももうExcel2003が動作する環境がないので、「反則」ですがVB.NETで代替策を探してみました。

(画像をクリックすると、このサンプルがダウンロードできます)
VB.NETでもFileSystemObjectは利用できるので、これとVB.NETでできる他の方法で処理時間を比較してみましょう。
この画像のクリックからダウンロードしたサンプルを適当なフォルダに解凍して、作成される「SearchFilesTEST1」フォルダ内の「SearchFilesTEST1.exe」を起動していただくと、この画面が表示されます。

「ファイル探索手段」の4種類は以下のような方法になります。現在、VBAでできるのは「④」だけです。

①My.Computer.FileSystem.FindInFiles

これはWeb上の検索で見つけた方法だったのですが、万単位のファイル数での検索となると生成に時間が掛かってVB.NET側のタイムアウトに掛かってしまう位です。関心がある方があれば試していただきたいのですが「実用に耐えない」というのがこちらの判断です。

②System.IOの通常のファイル探索(再帰動作)＋SearchPattern

System.IOのオブジェクトで標準のファイル探索方法で、FileSystemObjectと異なるのはサブフォルダ探索指定と検索ファイルパターンの指定ができることです。 ②ではサブフォルダ探索指定は行なわずにプログラム側で再帰動作で探索させて、1フォルダ内のファイル探索は検索ファイルパターンを使用しています。

③System.IOの通常のファイル探索(非再帰動作)＋SearchPattern

②と同様の方法で、プログラム側での再帰動作は行なわずにサブフォルダ探索指定と検索ファイルパターンの指定を行なう方法です。つまり、VBAのFileSearchに相当する方法だと思います。

④FileSystemObject(VBA同様の再帰動作)＋ファイル名Like判定

VBAでファイル探索に使用している「Microsoft Scripting Runtime」をVB.NETでも同様に参照設定して、同様に各フォルダを再帰動作で探索する方法です。

なお、処理時間が表示されますが、これはファイルの探索及びテーブル格納の時間のみで、Excelシートへの展開時間は含まれていません。
FileSearchの件で比較されるのであれば、③と④の処理時間を比較してみて下さい。処理後に表示されるのは、Excelに展開される時間は含まれていません。
当方の環境ではローカルディスク(HDD)の環境で、複数の階層のフォルダに合計で1万6千ファイルがあるところから、数十ファイルを探索する状態で ④は6秒強かかるのですが、③だと0.7秒程度という速さでした。

このVB.NET環境のプロジェクトはソースコードを含めて「ファイルの検索(VisualBasic)」からダウンロードできます。