Egg's Blog

Excel VBAへここから貼付け
____________________________________
Option Explicit
Option Compare Text

Function GetFiles(strPath As String, dctDict As Scripting.Dictionary, Optional blnRecursive As Boolean) As Boolean

' このプロシージャは、ディレクトリ内のすべてのファイルを
' Dictionary オブジェクトに返します。再帰的に呼び出
' される場合は、サブフォルダ内のファイルもすべて返します。

Dim fsoSysObj As Scripting.FileSystemObject
Dim fdrFolder As Scripting.Folder
Dim fdrSubFolder As Scripting.Folder
Dim filFile As Scripting.File

' 新しい FileSystemObject を返します。
Set fsoSysObj = New Scripting.FileSystemObject

On Error Resume Next
' フォルダを取得します。
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
' パスが間違っています。
GetFiles = False
GoTo GetFiles_End
End If
On Error GoTo 0
'**************************************************************************
Dim sDwg
sDwg = ".dwg"
Dim rightName

On Error Resume Next
' Files コレクションをループし、Dictionary に追加します。
For Each filFile In fdrFolder.Files

rightName = Right(filFile, 4)
If rightName = ".dwg" Then
dctDict.Add filFile.Path, filFile.Path
'dctDict.Add filFile.Name, filFile.Name

End If
Next filFile
'**************************************************************************
' 再帰フラグが真の場合、再帰的に呼び出します。
If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, dctDict, True
Next fdrSubFolder
End If

' エラーが発生しなかった場合は、True を返します。
GetFiles = True

GetFiles_End:
Exit Function
End Function
' __________________________________________________________________________________
Sub DWGファイル検索()

On Error Resume Next

Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")

Dim dctDict As Scripting.Dictionary
Dim varItem As Variant
Dim strDirPath As String

Dim dwgFile As String 'ファイル名
Dim pathDwg As String '検索フォルダの場所
Dim i As Integer 'カウント
' ファイル ダイアログを開きます。
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = True
.Show

Dim foName As String
foName = .SelectedItems(1)

End With

'******************************************

strDirPath = foName & "\"
' 新規 Dictionary を作成します。
Set dctDict = New Scripting.Dictionary
' 再帰的に呼び出し、Dictionary オブジェクトにファイルを返します。
If GetFiles(strDirPath, dctDict, True) Then
' Dictionary 内の項目を出力します。

Dim enCount
i = 2

For Each varItem In dctDict

Cells(i, 1).Value = varItem

Set f = fs.GetFile(varItem)

enCount = InStrRev(varItem, "\") + 1

Cells(i, 2).Value = Mid(varItem, enCount)
Cells(i, 3).Value = f.DateLastModified

i = i + 1
Next

Cells(1, 1).Value = strDirPath
Cells(1, 1).Font.Bold = True
Cells(1, 2).Value = dctDict.Count & " Files"
Cells(1, 2).Font.Bold = True

Columns("A:C").EntireColumn.AutoFit
Cells(1, 2).Select
End If

End Sub
__________________________________________________________________________________