| |
指定したフォルダのBook名を取得するのはこんなでも
（今、私が使っているコードです）
Sampleを試してください
Option Explicit
Public Sub Sample()
Dim i As Long
Dim rngResult As Range
Dim vntFileNames As Variant
Dim strSearchPath As String
Dim lngSubDir As Long
Dim strProm As String
'◆出力Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngResult = Worksheets(1).Cells(1, "A")
'ファイルを探す探すフォルダを指定
strSearchPath = ThisWorkbook.Path
'探すSubフォルダの階層を指定
'指定フォルダのみの場合＝0
'Subフォルダ全ての場合＝-1
'すぐ下のフォルダまで＝1
'下の下なら＝2
lngSubDir = -1
'ファイル名を抽出
'strBasePattan:探すファイル名を正規表現で指定
'strExtePattan：探すファイル名の拡張子を正規表現で指定
If Not GetFilesList(vntFileNames, strSearchPath, ".*", "xls|xlsm|xlsx", lngSubDir) Then
strProm = "ファイルが有りません"
GoTo Wayout
End If
'結果を出力
With rngResult
.Resize(, 2).Value = Array("Path", "BookName")
For i = 0 To UBound(vntFileNames, 2)
.Offset(i + 1, 0).Value = vntFileNames(0, i)
.Offset(i + 1, 1).Value = vntFileNames(1, i)
Next i
End With
strProm = "処理が完了しました"
Wayout:
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Public Function GetFilesList(vntFileNames As Variant, _
strFolderPath As String, _
Optional strBasePattan As String = ".*", _
Optional strExtePattan As String = ".*", _
Optional lngSubDir As Long = -1) As Boolean
Const clngLower As Long = 0
Dim objFSO As Object
Dim regName As Object
Dim vntRead As Variant
' 'FSOのオブジェクトを取得
Set objFSO = CreateObject("Scripting.FileSystemObject")
'フォルダの存在確認
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
GetFilesList = True
End If
Wayout:
Set objFSO = Nothing
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
'先頭に"~$"が無いなら
If Left(strName, 2) <> "~$" 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 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
- 08/6/28(土) 16:46 -
