VBAでPythonのGlob方式でファイルを検索するためのクラスを作成してみた

#目的
VBAでフォルダやファイルを検索する際、サブフォルダ内を検索する処理が複雑になるため、
PythonのGlobを参考にクラスモジュールを作成してみた。

#ソースコード

VBA 使用例

Module1.bas

Sub GlobTest()
    Dim item As Variant
    With New Glob
        .SetType = Dictionary ' 省略可 出力形式指定用
        For Each item In .iGlob("**\*.cls")
            Debug.Print item
        Next
    End With
End Sub

メソッド

名称	返り値
iGlob(パス)	フォルダ・ファイル検索結果(出力形式可変)
Glob(パス)	フォルダ・ファイル検索結果(Dictionary形式)
GlobFolder(パス)	フォルダのみ検索結果(Dictionary形式)

プロパティ

名称	値
SetType	出力形式
GetType	出力形式
GetCount	検索に一致した数
GetItems	iGlobの返り値と同一

出力形式種別

名称	形式
Dictionary	String()
Collection	File(),Folder()
ArrayList	String()
StringArray	String()

検索条件

記載内容	出力結果
\*\	同一パス内のフォルダを列挙
\*	同一パス内のファイルを列挙
\*.cls	同一パス内の拡張子がclsのファイルを列挙
\*\*	サブフォルダ内のファイルを列挙
\{*}\*	同一パス内とサブフォルダ内のファイルを列挙
\**\*	再帰的に検索してすべての階層のファイルを列挙

Python 参考コード例

import glob
for x in glob.glob('**/*.cls', recursive=True):
    print x

クラスモジュール本体

Glob.cls

Private DefPath As String
Private Items As Variant
Private FSO As Object

Enum GlobDataType
    None = 0
    StringArray = 1
    ArrayList = 2
    dictionary = 3
    Collection = 4
End Enum

Private Sub Class_Initialize()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    With CreateObject("WScript.Shell")
        .CurrentDirectory = ThisWorkbook.path & "\"
    End With
    Me.Clear
End Sub

Private Sub Class_Terminate()
    Set Items = Nothing
    Set FSO = Nothing
End Sub

Public Sub Clear()

    DefPath = ThisWorkbook.path & "\"
    count = 0
    Select Case Me.GetType
    Case GlobDataType.dictionary
        Me.SetType = dictionary
    Case GlobDataType.Collection
        Me.SetType = Collection
    Case GlobDataType.StringArray
        Me.SetType = StringArray
    Case GlobDataType.ArrayList
        Me.SetType = ArrayList
    Case Else
        Me.SetType = Collection
    End Select

End Sub

Public Function GetItems() As Variant
    Select Case Me.GetType
    Case GlobDataType.dictionary, GlobDataType.Collection, GlobDataType.ArrayList
        Set GetItems = Items
    Case GlobDataType.StringArray
        GetItems = Split(Items, "||")
    Case Else
        GetItems = Array()
    End Select
End Function

Public Function GetCount() As Long
    Select Case Me.GetType
    Case GlobDataType.dictionary, GlobDataType.Collection, GlobDataType.ArrayList
        GetCount = Items.count
    Case GlobDataType.StringArray
        If Items = "" Then
            GetCount = 0
        Else
            GetCount = UBound(Split(Items, "||")) + 1
        End If
    Case Else
        GetCount = -1
    End Select
End Function

Public Sub AddItem(ByVal name As String, ByVal v As Variant)
    Select Case Me.GetType
    Case GlobDataType.dictionary
        Items.Add name, v
    Case GlobDataType.Collection
        Items.Add v, name
    Case GlobDataType.ArrayList
        Items.Add v
    Case GlobDataType.StringArray
        If Items <> "" Then Items = Items & "||"
        Items = Items & v
    End Select
End Sub

Public Property Get GetType() As GlobDataType
    Select Case Me.GetTypeName
    Case "Collection"
        GetType = GlobDataType.Collection
    Case "Dictionary"
        GetType = GlobDataType.dictionary
    Case "String"
        GetType = GlobDataType.StringArray
    Case "ArrayList"
        GetType = GlobDataType.ArrayList
    Case Else
        GetType = GlobDataType.None
    End Select
End Property

Public Property Let SetType(ByVal TypeName As GlobDataType)
    Select Case TypeName
    Case GlobDataType.Collection
        Set Items = Nothing
        Set Items = New Collection
    Case GlobDataType.dictionary
        Set Items = Nothing
        Set Items = CreateObject("scripting.dictionary")
    Case GlobDataType.StringArray
        Items = ""
    Case GlobDataType.ArrayList
        Set Items = Nothing
        Set Items = CreateObject("System.Collections.ArrayList")
    Case Else
        Set Items = Nothing
        Set Items = CreateObject("scripting.dictionary")
    End Select
End Property

Public Function GetTypeName() As String
    GetTypeName = TypeName(Items)
End Function


Private Function base(ByRef url As String, Optional ByRef key As String = "") As String
    Dim baseUrl As String
    Dim min As Long
    Dim keystr As String
    
    If Left$(url, 2) <> "\\" And Left$(url, 1) = "\" Then url = Mid$(url, 2, Len(url) - 1)
    
    If url <> "" Then
        min = 2000
        If InStr(url, "?") And min > InStr(url, "?") Then min = InStr(url, "?")
        If InStr(url, "*") And min > InStr(url, "*") Then min = InStr(url, "*")
        If InStr(url, "[") And min > InStr(url, "[") Then min = InStr(url, "[")
        If InStr(url, "{") And min > InStr(url, "{") Then min = InStr(url, "{")
        If InStr(url, "]") And min > InStr(url, "]") Then min = InStr(url, "]")
        If InStr(url, "}") And min > InStr(url, "}") Then min = InStr(url, "}")
        If min < 2000 Then
            keystr = Left$(Left$(url, min - 1), InStrRev(Left$(url, min - 1), "\"))
            baseUrl = FSO.GetAbsolutePathName(keystr)
            key = Replace$(url, keystr, "")
        Else
            baseUrl = FSO.GetAbsolutePathName(url)
            key = ""
        End If
        If FSO.FolderExists(baseUrl) = True Then
            url = baseUrl
            base = baseUrl
        Else
            url = ""
            base = ""
        End If
    Else
        url = ""
        key = ""
        base = ""
    End If
End Function

Public Function iGlob(Optional ByVal url As String = "") As Variant

    Dim key As String
    key = ""
    Call base(url, key)
    Me.Clear
    Call subSearch(url, key, 0)
    If IsObject(Me.GetItems) = True Then
        Set iGlob = Me.GetItems
    Else
        iGlob = Me.GetItems
    End If

End Function

Public Function Glob(Optional ByVal url As String = "") As Object

    With New Glob
        .SetType = dictionary
        Set Glob = .iGlob(url)
    End With

End Function

Public Function GlobFolder(Optional ByVal url As String = "") As Object

    Dim item As Variant
    Dim List As Object
    Set List = CreateObject("scripting.dictionary")
    With New Glob
        .SetType = Collection
        For Each item In Me.iGlob(url)
            If TypeName(item) = "File" Then
                If List.Exists(item.ParentFolder) = False Then
                    List.Add item.ParentFolder, item.ParentFolder
                End If
            Else
                If List.Exists(item.path) = False Then
                    List.Add item.path, item.path
                End If
            End If
        Next
    End With
    Set GlobFolder = List
    Set List = Nothing

End Function

Private Function subSearch(ByVal baseUrl As String, ByVal key As String, Optional ByVal level As Long = 0) As String

    Dim keyArr As Variant
    Dim folder As Variant
    Dim File As Variant
    
    keyArr = Split(key, "\")
    
    If UBound(keyArr) > level Then
    
        If keyArr(level) = "**" Then
            Call recursive(baseUrl, key, level + 1)
        ElseIf keyArr(level) Like "{*}" Then
        
            For Each folder In FSO.GetFolder(baseUrl).SubFolders
                If folder.name Like keyArr(level) Then
                    Call subSearch(baseUrl & "\" & folder.name, key, level + 1)
                End If
            Next
            Call subSearch(baseUrl, key, level + 1)
        
        Else
        
            For Each folder In FSO.GetFolder(baseUrl).SubFolders
                If folder.name Like keyArr(level) Then
                    Call subSearch(baseUrl & "\" & folder.name, key, level + 1)
                End If
            Next
        
        End If
    
    Else

        If keyArr(level) = "" Then
        
            If FSO.FolderExists(baseUrl) = True Then
                Me.AddItem baseUrl, FSO.GetFolder(baseUrl)
            End If
        
        Else

            For Each File In FSO.GetFolder(baseUrl).Files
                If File.name Like keyArr(level) Then
                    Me.AddItem File, File
                End If
            Next
        
        End If
    
    End If
    
    

End Function

Private Function recursive(ByVal baseUrl As String, ByVal key As String, Optional ByVal level As Long = 0) As String
    
    Dim folder As Variant
    Dim keyArr As Variant
    Dim File As Variant
    
    keyArr = Split(key, "\")
    
    If UBound(keyArr) > level Then
    
        For Each folder In FSO.GetFolder(baseUrl).SubFolders
            If folder.name Like keyArr(level) Then
                Call subSearch(baseUrl & "\" & folder.name, key, level + 1)
            ElseIf "{" & folder.name & "}" Like keyArr(level) Then
                Call subSearch(baseUrl, key, level)
            Else
                Call recursive(baseUrl & "\" & folder.name, key, level)
            End If
        Next

    Else
        For Each folder In FSO.GetFolder(baseUrl).SubFolders
            Call recursive(baseUrl & "\" & folder.name, key, level)
        Next
        For Each File In FSO.GetFolder(baseUrl).Files
            If File.name Like keyArr(level) Then
                Me.AddItem File, File
            End If
        Next
    End If
    
End Function

今後の課題

• 特殊文字のエスケープ、正規表現での条件指定を実装する。
• \**\**\と入力したときの動作の検証が出来ていない
• 出力形式に配列(Array)を実装（速度比較のため）

利用されるみなさまへ

• デバッグがしきれていないため、動作に不具合があれば見直ししますので、
  情報共有頂けると幸いです。よろしくお願いいたします。

参考サイト

• Pythonで条件を満たすパスの一覧を再帰的に取得するglobの使い方

• 長さ0文字以上の任意の文字列: *

• 任意の一文字: ?

• 特定の一文字: []

• 特殊文字のエスケープ

• 再帰的に取得: 引数recursive → 引数指定せず使用可能に

• ファイル名のみ取得

• ディレクトリ名のみ取得

• 正規表現で条件指定

• イテレータで一覧を取得: iglob()

• glob --- Unix 形式のパス名のパターン展開

• Excel VBAで使える可変長なコレクションまとめ

• Collection

• Dictionary

• ArrayList

• SortedList
  ※処理速度比較用に実装

• 【VBA入門】Like演算子(ワイルドカード、エスケープ、否定)

ワイルドカード

文字	説明
?	任意の1文字
*	0文字以上の文字
#	0～9の半角数字
[charlist]	charlistに含まれる全角または半角の1文字
[!charlist]	charlistに含まれない全角または半角の1文字