Last active
April 22, 2020 01:58
-
-
Save furyutei/50fcbb6d3afd3a8952b1eecf770559c7 to your computer and use it in GitHub Desktop.
VBAでフォルダ下のファイルリストを高速に取得する試み
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
' ファイルリスト取得用独自外部コマンド(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
はけた@Excel最高の学び方発売中さんのツイート: "あんまりDOSプロンプトは呼び出したくないですけれど。 速度が大幅に向上するなら、検討の余地はあるのかもしれません。 でも、他人用で使うのはなんとなく怖いので、使うとしても自分専用かな?"
経由