Option Explicit
Private Const DEF_SEARCH_LIMIT = 20000 '上限のデフォルト
Public FSO_FoundFilesUnit() As String '検索結果代入用の変数
Private cntFound(0 To 1) As Long
Private sizeTOTAL As Double
Private boolLIMIT As Boolean
'Unit-1 インターフェイス
Function funct_FSO_SEARCH(ByVal SearchPath As Variant, _
ByVal NamePattern As Variant, ByVal SearchLIMIT As Long) As Long
Erase cntFound
sizeTOTAL = 0
Dim strPATHNAME As String
Dim strFILENAME As String
Dim lngLIMIT As Long
strPATHNAME = CStr(SearchPath) '検索パス
strFILENAME = CStr(NamePattern) 'ファイル名
lngLIMIT = Val(SearchLIMIT) 'FoundFiles の上限値
' 検索対象フォルダが空白
If Len(strPATHNAME) = 0 Then
funct_FSO_SEARCH = 0
Exit Function
End If
' 検索結果の上限値が 0
If lngLIMIT = 0 Then
lngLIMIT = DEF_SEARCH_LIMIT
End If
'検索結果の限界数
Erase FSO_FoundFilesUnit
ReDim FSO_FoundFilesUnit(lngLIMIT)
Dim objTarget As Object
Dim TotalSFS As Double
Dim stbDivisor As Integer
' 指定されたフォルダが存在するか
Set objTarget = CreateObject("Scripting.FileSystemObject")
If objTarget.FolderExists(strPATHNAME) = False Then
funct_FSO_SEARCH = 0
Set objTarget = Nothing
Exit Function
End If
' フォルダのファイルサイズ
TotalSFS = objTarget.GetFolder(strPATHNAME).Size
' StatusBarを表記するタイミング
Select Case TotalSFS
Case 1 To 5 * (1024 ^ 2)
stbDivisor = 1
Case 5 * (1024 ^ 2) To 10 * (1024 ^ 2)
stbDivisor = 10
Case 10 * (1024 ^ 2) To 50 * (1024 ^ 2)
stbDivisor = 25
Case 50 * (1024 ^ 2) To 200 * (1024 ^ 2)
stbDivisor = 50
Case Is > 200 * (1024 ^ 2)
stbDivisor = 100
End Select
Set objTarget = Nothing
' 上限到達フラグの初期化
boolLIMIT = False
' 検索
Application.Run "SEARCH_FOLDER", strPATHNAME, strFILENAME, lngLIMIT, stbDivisor
' 検索上限以内 → 戻り値はファイル数
If boolLIMIT = False Then
funct_FSO_SEARCH = cntFound(1)
' 検索上限超過 → 戻り値は -1
ElseIf boolLIMIT = True Then
funct_FSO_SEARCH = -1
End If
Application.StatusBar = False
Erase cntFound
sizeTOTAL = 0
End Function
'Unit-2 検索SubプロージャA
Sub SEARCH_FOLDER(ByVal orgPathName As Variant, ByVal targetFileName As Variant, _
ByVal SearchLIMIT As Long, ByVal BarsDivisor As Integer)
' 検索上限に達している
If boolLIMIT = True Then
Exit Sub
End If
Dim strPATHNAME As String
Dim strFILENAME As String
strPATHNAME = CStr(orgPathName)
strFILENAME = CStr(targetFileName)
Dim objFS As Object
Dim objFSBody As Object
Set objFS = CreateObject("Scripting.FileSystemObject")
If strPATHNAME = "" Then
Exit Sub
End If
If objFS.FolderExists(strPATHNAME) = False Then
Exit Sub
End If
Set objFSBody = objFS.GetFolder(strPATHNAME)
Call SEARCH_SUB_FOLDER(objFSBody.Path, strFILENAME, SearchLIMIT, BarsDivisor, 0)
Set objFSBody = Nothing
Set objFS = Nothing
Application.StatusBar = False
End Sub
'Unit-3 検索SubプロージャB
Private Sub SEARCH_SUB_FOLDER(ByVal objPATH As String, ByVal srcTarget As String, _
ByVal SearchLIMIT As Long, ByVal BarsDivisor As Integer, ByRef FoundFilesCount As Long)
' 検索上限に達している
If boolLIMIT = True Then
Exit Sub
End If
' 検索結果の上限
Dim lngLIMIT As Long
lngLIMIT = Val(SearchLIMIT)
' ステータスバー表記タイミング
Dim stbDivisor As Integer
stbDivisor = Val(BarsDivisor)
If stbDivisor = 0 Then
stbDivisor = 1
End If
Dim objBasic As Object
Dim objSrcFolder As Object
Dim objFoundSubFolder As Object
Dim objFoundFile As Object
Set objBasic = CreateObject("Scripting.FileSystemObject")
Set objSrcFolder = objBasic.GetFolder(objPATH)
Set objFoundSubFolder = CreateObject("Scripting.FileSystemObject")
Set objFoundFile = CreateObject("Scripting.FileSystemObject")
cntFound(0) = cntFound(0) + 1 ' 参照フォルダ数を加算
'サブフォルダ探索
For Each objFoundSubFolder In objSrcFolder.SubFolders
' フォルダ単位のサブ処理(再帰呼び出し)
Call SEARCH_SUB_FOLDER(objFoundSubFolder.Path, srcTarget, lngLIMIT, stbDivisor, FoundFilesCount)
Next objFoundSubFolder
' 検索結果の割り当て
For Each objFoundFile In objSrcFolder.Files
With objFoundFile
Select Case cntFound(1)
Case Is <= lngLIMIT
If .Name Like srcTarget Then
cntFound(1) = cntFound(1) + 1
sizeTOTAL = sizeTOTAL + .Size
FoundFilesCount = FoundFilesCount + 1
FSO_FoundFilesUnit(cntFound(1)) = .Path
End If
' 検索上限に達した
If cntFound(1) = lngLIMIT Then
boolLIMIT = True
Exit For
End If
End Select
End With
' ステータスバー
If cntFound(1) Mod stbDivisor = 0 Then
Application.StatusBar = "Folder:= " & objSrcFolder.Path & " / Files:= " & cntFound(1) & _
" / Size:= " & Format(sizeTOTAL / (1024 ^ 2), "0.0""MB""")
End If
Next objFoundFile
Set objBasic = Nothing
Set objSrcFolder = Nothing
Set objFoundSubFolder = Nothing
Set objFoundFile = Nothing
End Sub