| |
現在の「Private Function GetFileNames」を削除して
以下の2つのプロシージャと差し替えて下さい
Private Function GetFileNames(vntFileNames As Variant, _
strFolderPath As String, _
objFSO As Object, _
Optional strBasePattan As String = ".*", _
Optional strExtePattan As String = ".*", _
Optional lngSubDir As Long = -1) As Boolean
Const clngLower As Long = 0
Dim regName As Object
Dim vntRead As Variant
'フォルダの存在確認
If Not objFSO.FolderExists(strFolderPath) Then
GoTo Wayout
End If
Set regName = CreateObject("VBScript.RegExp")
'大文字と小文字を区別しないように設定
regName.IgnoreCase = True
'ファイル名List配列の初期化
ReDim vntRead(1, clngLower To 1)
'ファイル名Listの作成
GetFilePath vntRead, _
objFSO.GetFolder(strFolderPath), _
strBasePattan, strExtePattan, _
regName, objFSO, lngSubDir
'ファイル名List配列の先頭値が""で無いなら
If vntRead(0, clngLower) <> "" Then
vntFileNames = vntRead
GetFileNames = True
End If
Wayout:
Set regName = Nothing
End Function
Private Sub GetFilePath(vntFileNames As Variant, _
objFolder As Object, _
strBasePattan As String, _
strExtePattan As String, _
regName As Object, _
objFSO As Object, _
ByVal lngSubDir As Long)
Dim lngLower As Long
Dim i As Long
Dim objFile As Object
Dim objSubDir As Object
Dim strDirPath As String
Dim strName As String
'List配列の最小添え字を取得
lngLower = LBound(vntFileNames, 2)
'List配列に値が有る場合
If vntFileNames(0, lngLower) <> "" Then
'カウンタをList配列の最大添え字に設定
i = UBound(vntFileNames, 2)
Else
'カウンタをList配列の最小添え字以下に設定
i = lngLower - 1
End If
'現在のFoderPathを取得
strDirPath = objFolder.Path & "\"
'ファイル名を列挙
For Each objFile In objFolder.Files
strName = objFile.Name
With regName
'拡張子を比較
.Pattern = strExtePattan
If .TEST(objFSO.GetExtensionName(strName)) Then
'Base名を比較
.Pattern = strBasePattan
If .TEST(objFSO.GetBaseName(strName)) Then
'カウンタをインクリメント
i = i + 1
'List配列を拡張
ReDim Preserve vntFileNames(1, lngLower To i)
'Path、ファイル名を代入
vntFileNames(0, i) = strDirPath
vntFileNames(1, i) = strName
End If
End If
End With
Next objFile
Set objFile = Nothing
'指定階層数になるまで再帰、lngSubDir < 0 の時は最終階層まで再帰
If lngSubDir > 0 Or lngSubDir < 0 Then
'階層指定を一つ下げる
lngSubDir = lngSubDir - 1
'SubFolderを探索
For Each objSubDir In objFolder.SubFolders
GetFilePath vntFileNames, objSubDir, _
strBasePattan, strExtePattan, _
regName, objFSO, lngSubDir
Next objSubDir
End If
Set objSubDir = Nothing
End Sub
後、呼び出し側の「Private Function GetFilesList」に就いて
もし、指定Folrder以下のSubFolrder全てなら、「Private Function GetFilesList」を
変更せず其のままで出来ます
また、指定Folrderの直ぐ下のFolderまでなら以下の様に変更して下さい
「Private Function GetFilesList」の中の
'指定形式のファイル名を取得
strCompe = "^[0-9][0-9][01][0-9][0-3][0-9]$|^[0-9][0-9][01][0-9][0-3][0-9]_[0-9]+$"
If Not GetFileNames(vntFiles, strPath, objFso, strCompe, "txt") Then
GoTo Wayout
End If
を
'指定形式のファイル名を取得
strCompe = "^[0-9][0-9][01][0-9][0-3][0-9]$|^[0-9][0-9][01][0-9][0-3][0-9]_[0-9]+$"
If Not GetFileNames(vntFiles, strPath, objFso, strCompe, "txt", 1) Then
GoTo Wayout
End If
にする
新しい、「Private Function GetFileNames」は、引数が1つ増え、
最後の引数がSubFolderの階層を指定しています
意味は、0＝指定Folder、1＝指定Folder因り1つ下まで、2＝指定Folder因り2つ下まで、・・・
尚、ここに-1を指定するか、何も指定しない場合、
指定Folder以下全てのSubFilderが対象と成ります
尚、このコードは、再帰呼び出しを使って居ますので
多分相当遅く成ると思います
また、再帰の常で、余り深い階層に成るとスッタクオーバーと成りますので、
気を就けて下さい
ただ、Win98でも3〜4層した程度なら使えると思います
（WinXP、Win2000のOSならもっと下まででも行けると思いますが、
くれぐれも、「C:\以下全て」の様な使い方をし無い方が無難です）
|
|
Hirofumi
- 06/1/7(土) 21:52 -
