| |
今使っている、コードを少し変更した物で余り上手く有りませんが？
再帰呼び出しでSubFolderも探して居ます
Option Explicit
Sub ファイル一覧_2()
Dim myFSO As Object
Dim i As Long
'フォルダー取得
Dim myShell As Object, myPath As Object
Dim vntFiles As Variant
Set myShell = CreateObject("Shell.Application")
Set myPath = myShell.BrowseForFolder(0, "フォルダを選択して下さい", &H11)
'If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
'FSOのオブジェクトを取得
Set myFSO = CreateObject("Scripting.FileSystemObject")
'ファイル名取得
If Not GetFilesList(vntFiles, myPath.Items.Item.Path, myFSO, , , -1) Then
GoTo Wayout
End If
With ActiveSheet
.Cells(1, 1).Resize(, 5).Value _
= Array("No", "ファイル名", "作成日", "サイズ", "パス")
With .Cells(2, 1)
.Value = 1
.Resize(UBound(vntFiles, 2) + 1).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, _
Date:=xlDay, Step:=1, Trend:=False
.Offset(, 1).Resize(UBound(vntFiles, 2) + 1, 4).Value = vntFiles
End With
End With
Wayout:
Set myFSO = Nothing
Set myPath = Nothing
Set myShell = Nothing
End Sub
Private Function GetFilesList(vntFileNames As Variant, _
strFolderPath As String, _
objFSO As Object, _
Optional strBasePattan As String = ".*", _
Optional strExtePattan As String = ".*", _
Optional lngSubDir As Long = -1) As Boolean
' vntFileNames : ファイル名等が返される変数（配列）
' strFolderPath : 探し始めるフォルダを指定
' strBasePattan : ファイルのBase名を正規表現で指定
' strExtePattan : ファイル拡張子を正規表現で指定
' lngSubDir : 探すサブフォルダの階層を指定、0はstrFolderPath、1はstrFolderPathの下の
' -1ははstrFolderPath以下全てのサブフォルダ
' 戻り値 : 値が在った場合、Trueを返す
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(3, clngLower To 1)
'ファイル名Listの作成
GetFilePath vntRead, _
objFSO.GetFolder(strFolderPath), _
strBasePattan, strExtePattan, _
regName, objFSO, lngSubDir
'ファイル名List配列の先頭値が""で無いなら
If vntRead(0, clngLower) <> "" Then
vntFileNames = Application.WorksheetFunction.Transpose(vntRead)
GetFilesList = 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(3, lngLower To i)
'Path、ファイル名を代入
vntFileNames(0, i) = strName
vntFileNames(1, i) = objFile.Datecreated
vntFileNames(2, i) = objFile.Size
vntFileNames(3, i) = objFile.Path
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
|
|
Hirofumi
- 09/7/15(水) 16:28 -
