VBAでフォルダ下のファイルリストを高速に取得する試み

0.README.md

[Excel] VBA でフォルダ下のファイルリストを高速に取得する試み

ソースコード

1. ファイルリスト取得用 VBA ソースコード＆テストコード (GetFileList.vba)
2. ファイルリスト取得用独自外部コマンド：GetFilelist.exe の VB.NET ソースコード (Module1.vb)
3. AsuExtendedClassLibrary.dll の.NET Framework ソースコード (FolderOperation.vb)

FolderOperation.vb

Imports System.Collections.Concurrent
Imports System.IO

' クラスをCOM経由でアクセス可能にする
<ComClass(FolderOperation.ClassId, FolderOperation.InterfaceId, FolderOperation.EventsId)>
Public Class FolderOperation

    ' COM用のGUID値
    Public Const ClassId As String = "55671817-7D3B-43A8-AFD9-67419DE34442"
    Public Const InterfaceId As String = "ADD57B31-105F-414D-9231-3B9FF98388F5"
    Public Const EventsId As String = "13807F8C-A198-4177-9C8E-B784B5F71BDA"

    ' VBAから利用できるメソッド
    Public Const FilelistKindFiles = 1
    Public Const FilelistKindFolder = 2
    Public Const FilelistKindBoth = FilelistKindFiles Or FilelistKindFolder

    Private FileNameBag As ConcurrentBag(Of String)
    Private FolderNameBag As ConcurrentBag(Of String)

    Public Function GetFilelist(ByVal TargetFolderName As String, Optional ByVal kind As Long = FilelistKindFiles) As String()
        ' TODO:
        '   Public Function GetFilelist(ByVal TargetFolderName As String, ByRef Filelist As String(), ByRef FolderList As String()) As String()
        '   のように、Byref で指定した文字列配列を引数にした場合、VBA からの受け渡しがうまく動作しない模様

        If Not System.IO.Directory.Exists(TargetFolderName) Then
            Return {}
        End If

        FileNameBag = New ConcurrentBag(Of String)
        FolderNameBag = New ConcurrentBag(Of String)

        FolderNameBag.Add(TargetFolderName & IIf(Right(TargetFolderName, 1) = "\", "", "\"))

        Dim FolderInfo As New DirectoryInfo(TargetFolderName)
        ScanFolder(FolderInfo)

        Dim Filelist = DirectCast(FileNameBag.ToArray, String())
        Dim FolderList = DirectCast(FolderNameBag.ToArray, String())
        Dim FileFolderList As String() = {}

        If kind And FilelistKindFiles Then FileFolderList = FileFolderList.Concat(Filelist).ToArray()
        If kind And FilelistKindFolder Then FileFolderList = FileFolderList.Concat(FolderList).ToArray()

        Array.Sort(FileFolderList)

        Return FileFolderList
    End Function

    Private Sub ScanFolder(FolderInfo As DirectoryInfo)
        Try
            Parallel.ForEach(FolderInfo.GetDirectories, Sub(SubFolder)
                                                            FolderNameBag.Add(SubFolder.FullName & IIf(Right(SubFolder.FullName, 1) = "\", "", "\"))
                                                            ScanFolder(SubFolder)
                                                        End Sub)
            For Each file In FolderInfo.GetFiles
                FileNameBag.Add(file.FullName)
            Next
        Catch
        End Try
    End Sub

End Class

GetFileList.vba

Option Explicit

' 元ネタ：[VBAでファイルリストを高速に取得する関数を自作する - えくせるちゅんちゅん](https://kotori-chunchun.hatenablog.com/entry/2019/01/03/184325)

Private Const TEST_MODE As Boolean = False
Private Const DEBUG_MODE As Boolean = False
'Private Declare Function SafeArrayAllocDescriptor Lib "oleaut32" (ByVal cDims As Long, ByRef ppsaOut() As Any) As Long

Function TrimEx(TargetString As String, Optional TrimLeft As Boolean = True, Optional TrimRight As Boolean = True) As String
    Dim reg_pattern As String
    
    If TrimLeft And TrimRight Then
        reg_pattern = "(?:^\s+|\s+$)"
    ElseIf TrimLeft Then
        reg_pattern = "^\s+"
    ElseIf TrimRight Then
        reg_pattern = "\s+$"
    Else
        TrimEx = TargetString
        Exit Function
    End If
    
    With CreateObject("VBScript.RegExp")
        .Pattern = reg_pattern
        .IgnoreCase = False
        .Global = True
        TrimEx = .Replace(TargetString, "")
    End With
End Function

' 参照：[Excel VBA効率的にファイル名を取得する機能](https://stackoverrun.com/ja/q/7205728)
Function Function_FileList(FolderLocation As String) As String()
    'Function_FileList = Filter(Split(TrimEx(CreateObject("Wscript.Shell").Exec("cmd /C dir /S /B /A-D """ & FolderLocation & """").StdOut.ReadAll), vbCrLf), ".")
    Function_FileList = Split(TrimEx(CreateObject("Wscript.Shell").Exec("cmd /C dir /S /B /A-D """ & FolderLocation & """").StdOut.ReadAll), vbCrLf)
    ' → '\u301c'（波ダッシュ・波型） のような文字は化けてしまう
End Function

Function GetFileListTmpfile(FolderLocation As String, Optional ShowCmdWindow As Boolean = True, Optional ExternalCommand As String = "") As String()
    GetFileListTmpfile = Split(vbNullString) ' 配列の要素数を0に
        
    Dim tmpfile As String
    Dim filelist() As String
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim cmdline As String
    Dim result As Long
    
    With fso
        If Not .FolderExists(FolderLocation) Then
            Debug.Print "* Error * Folder(" & FolderLocation & ") not found"
            Exit Function
        End If
        Do
            tmpfile = .GetSpecialFolder(2) & "\" & .GetTempName ' GetSpecialFolder の 引数(2) は TemporaryFolder (「Microsoft Scripting Runtime」有効時は定数)
        Loop While .FileExists(tmpfile)
    End With

    If ExternalCommand = "" Then
        cmdline = "cmd /U /C dir /S /B /A-D """ & FolderLocation & """"
    Else
        cmdline = "cmd /U /C """"" & ExternalCommand & """ """ & FolderLocation & """"""
    End If
    
    cmdline = cmdline & " > " & tmpfile
    
    result = CreateObject("Wscript.Shell").Run(cmdline, IIf(ShowCmdWindow, vbNormalFocus, vbHide), True)
    
    'コマンドプロンプト表示がONで強制終了（中断）された時の対策
    If result <> 0 Then
        If fso.FileExists(tmpfile) Then
            On Error Resume Next
            Kill tmpfile
            On Error GoTo 0
        End If
        Debug.Print "* Stop * Command terminated with error or user interrupt"
        Exit Function
    End If
    
    With CreateObject("ADODB.Stream")
        .Charset = "Unicode"
        .Open
        .LoadFromFile tmpfile
        filelist = Split(TrimEx(.ReadText), vbCrLf)
        .Close
    End With

    Kill tmpfile
        
    GetFileListTmpfile = filelist
End Function

Function GetFileListClip(FolderLocation As String, Optional ShowCmdWindow As Boolean = True) As String()
    GetFileListClip = Split(vbNullString) ' 配列の要素数を0に
    
    Dim filelist() As String
    Dim result As Long
    
    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(FolderLocation) Then
            Debug.Print "* Error * Folder(" & FolderLocation & ") not found"
            Exit Function
        End If
    End With
    
    result = CreateObject("Wscript.Shell").Run("cmd /C chcp 65001 & cmd /C dir /S /B /A-D """ & FolderLocation & """ | clip", IIf(ShowCmdWindow, vbNormalFocus, vbHide), True)
    ' ※ "cmd /C chcp 65001 | dir /S /B /A-D """ & FolderLocation & """ | clip" にすると、ごくまれに文字化けすることがある模様
        
    'コマンドプロンプト表示がONで強制終了（中断）された時の対策
    If result <> 0 Then
        Debug.Print "* Stop * Command terminated with error or user interrupt"
        Exit Function
    End If
    
'    With New DataObject '  ツール(T)→参照設定(R)→□ Microsoft Forms 2.0 Object Library (FM20.DLL) が必要
'        .GetFromClipboard
'        If .GetFormat(1) Then
'            filelist = Split(.GetText, vbCrLf)
'            ' TODO: たまに実行時エラーとなってしまう
'            '   実行時エラー '-2147221040 (800401d0)'
'            '   DataObject:GetText OpenClipboard に失敗しました
'        Else
'            Debug.Print "* Error * Could not get data from clipboard"
'            Exit Function
'        End If
'    End With
    
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        If .CanPaste Then
            .Paste
            ' TODO: クリップボードを使用する他のプロセスが割り込んだ場合、不正な動作となってしまう
            filelist = Split(TrimEx(.Text), vbCrLf)
        Else
            Debug.Print "* Error * Could not get data from clipboard"
            Exit Function
        End If
    End With
    
    GetFileListClip = filelist
End Function

Function GetFileList(FolderLocation As String, Optional UseClipboard As Boolean = False, Optional UseExternalCommand = False) As String()
    If UseClipboard Then
        GetFileList = GetFileListClip(FolderLocation)
    Else
        If UseExternalCommand Then
            GetFileList = GetFileListTmpfile(FolderLocation, ExternalCommand:=ThisWorkbook.Path & "\" & "GetFilelist.exe")
        Else
            GetFileList = GetFileListTmpfile(FolderLocation)
        End If
    End If
End Function

Function GetFileListCom(FolderLocation As String) As String()
    GetFileListCom = CreateObject("AsuExtendedClassLibrary.FolderOperation").GetFileList(FolderLocation)
End Function

Sub test()
    ThisWorkbook.Activate
    Sheets("Sheet1").Activate
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim foldername As String
    Dim starttime As Double
    Dim elapsedtime As Double
    Dim filelist() As String
    Dim filenumber As Long
        
    foldername = Range("B1").value
    
    starttime = Timer
'    filelist = Function_FileList(foldername) ' DIR の実行結果を .StdOut.ReadAll で取り込み
'    filelist = GetFileList(""" & time /T > foo.txt & dir """ & foldername) ' Command Injection チェック用
'    filelist = GetFileList(foldername, UseClipboard:=True) ' DIRコマンド実行結果をクリップボード経由で取り込み
    filelist = GetFileList(foldername) ' DIRコマンド実行結果を一時ファイル経由で取り込み
'    filelist = GetFileList(foldername, UseExternalCommand:=True) ' 独自外部コマンド（GetFilelist.exe）の実行結果を一時ファイル経由で取り込み
'    filelist = GetFileListCom(foldername) ' Visual Studio(VB.NET)で作成した独自DLL（AsuExtendedClassLibrary.dll）による取り込み
    
    elapsedtime = Timer - starttime
    
    Range("A:A").Clear
    
    filenumber = UBound(filelist) - LBound(filelist) + 1
    
    If 0 < filenumber Then
        Range("A1:A" & filenumber).value = WorksheetFunction.Transpose(filelist)
    End If
    
    If Not TEST_MODE Then GoTo ENDPOINT
    
    Dim filename As Variant
    Dim lineno As Long
    Dim errorcount As Long
    
    lineno = 0
    errorcount = 0
    
    With CreateObject("Scripting.FileSystemObject")
        For Each filename In filelist
            lineno = lineno + 1
            If DEBUG_MODE Then Debug.Print lineno & ": " & filename
            If Not .FileExists(filename) Then
                Debug.Print "** Error ** " & filename
                errorcount = errorcount + 1
            End If
        Next filename
    End With
    
    Debug.Print "Error: " & errorcount

ENDPOINT:
    Debug.Print "File number: " & filenumber
    Debug.Print "Elapsed Time: " & Format(elapsedtime, "0.0000") & " sec"
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Range("A1").Select
End Sub

Module1.vb

' ファイルリスト取得用独自外部コマンド（GetFilelist.exe）

' 参考：[VBA - 【VBA】サブディレクトリも含めたファイル一覧を素早く取得したい｜teratail](https://teratail.com/questions/84495)

Imports System.Collections.Concurrent
Imports System.IO
Imports System.Text

Module Module1

    Private Enum ReturnCode
        OK = 0
        ArgumentError = -1
        FolderNotFound = -2
    End Enum

    Private CommandFullname As String

    Private FileNameBag As ConcurrentBag(Of String)

    Function Main() As Integer
        Console.OutputEncoding = Encoding.Unicode

        Dim args = Environment.GetCommandLineArgs
        Dim targetfolder = ""

        CommandFullname = args(0)

        If args.Length = 1 Then
            targetfolder = "."
        ElseIf args.Length = 2 Then
            targetfolder = args(1)

            If targetfolder = "/?" Then
                Usage()
                Return ReturnCode.ArgumentError
            End If
        Else
            Usage()
            Return ReturnCode.ArgumentError
        End If

        If Not System.IO.Directory.Exists(targetfolder) Then
            Console.WriteLine("Error: """ & targetfolder & """ not found" & vbCrLf)
            Return ReturnCode.FolderNotFound
        End If

        Dim sw = Stopwatch.StartNew

        Dim fileNames = GetFilelist(targetfolder)

        Dim scanTime = sw.Elapsed.TotalSeconds

        sw.Restart()

        For Each fileName In fileNames
            Console.WriteLine(fileName)
        Next

        Dim outputTime = sw.Elapsed.TotalSeconds

        'Console.WriteLine("ファイル数=" & fileNames.Length & " スキャン時間=" & scanTime & " 出力時間=" & outputTime)
        'Console.ReadLine()

        Return ReturnCode.OK
    End Function

    Sub Usage()
        Console.WriteLine("Usage: " & CommandFullname & " <target folder>")
    End Sub

    Private Function GetFilelist(targetfolder As String) As Array
        FileNameBag = New ConcurrentBag(Of String)
        Dim Directory As New DirectoryInfo(targetfolder)
        ScanFolder(Directory)
        Dim fileNames = FileNameBag.ToArray
        Array.Sort(fileNames)
        GetFilelist = fileNames
    End Function

    Private Sub ScanFolder(directory As DirectoryInfo)
        Try
            Parallel.ForEach(directory.GetDirectories, Sub(subDir) ScanFolder(subDir))
            For Each file In directory.GetFiles
                FileNameBag.Add(file.FullName)
            Next
        Catch
        End Try
    End Sub

End Module

Visual Studioで作成した、COM参照可能にした.NET FrameworkのDLLのソースコード（FolderOperation.vb）を追加。
これに伴い、VBAのサンプルソース（GetFileList.vba）に当該DLL（AsuExtendedClassLibrary.dll）を用いた関数追加