Skip to content

Instantly share code, notes, and snippets.

@furyutei
Last active April 22, 2020 01:58
Show Gist options
  • Save furyutei/50fcbb6d3afd3a8952b1eecf770559c7 to your computer and use it in GitHub Desktop.
Save furyutei/50fcbb6d3afd3a8952b1eecf770559c7 to your computer and use it in GitHub Desktop.
VBAでフォルダ下のファイルリストを高速に取得する試み
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
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
' ファイルリスト取得用独自外部コマンド(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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment