Help us understand the problem. What is going on with this article?

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)を実装(速度比較のため)

利用されるみなさまへ

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

参考サイト

  • 長さ0文字以上の任意の文字列: *
  • 任意の一文字: ?
  • 特定の一文字: []
  • 特殊文字のエスケープ
  • 再帰的に取得: 引数recursive → 引数指定せず使用可能に
  • ファイル名のみ取得
  • ディレクトリ名のみ取得
  • 正規表現で条件指定
  • イテレータで一覧を取得: iglob()
  • Collection
  • Dictionary
  • ArrayList
  • SortedList
    ※処理速度比較用に実装

ワイルドカード

文字 説明
? 任意の1文字
* 0文字以上の文字
# 0~9の半角数字
[charlist] charlistに含まれる全角または半角の1文字
[!charlist] charlistに含まれない全角または半角の1文字
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
No comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
ユーザーは見つかりませんでした