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
@furyutei
Copy link
Author

furyutei commented Jan 7, 2019

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment