'***************************************************************************************************
' 指定したフォルダ内のファイルの一覧を取得 Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'03/07/27(1.00)新規作成
'12/01/28(1.01)初回修正
'20/02/27(1.10)*.xlsm化、フォルダ参照を汎用化(modFolderPicker2)、他
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
Private Const g_cnsTitle As String = "フォルダ内のファイル名一覧取得"
Private Const g_cnsDir As String = "\*.*"
'***************************************************************************************************
' ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :Display_Directory
'* 機能 :指定したフォルダ内のファイルの一覧を取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月27日
'* 作成者 :井上 治
'* 更新日 :2020年02月27日
'* 更新者 :井上 治
'* 機能説明:Dir関数による指定フォルダ内のファイル名一覧の取得
'* 注意事項:サンプルなのでエラー処理は行なっていません
'***************************************************************************************************
Sub Display_Directory()
'-----------------------------------------------------------------------------------------------
Dim lngRow As Long ' シート上の行
Dim strPathname As String ' フォルダ名
Dim strFilename As String ' ファイル名
'-----------------------------------------------------------------
' ①「フォルダの参照」ダイアログ表示(汎用機能)
strPathname = modFolderPicker2.FolderDialog(g_cnsTitle)
' 未選択は終了
If strPathname = "" Then Exit Sub
'-----------------------------------------------------------------
' ②先頭のファイル名の取得
strFilename = Dir(strPathname & g_cnsDir, vbNormal)
'-----------------------------------------------------------------
' ③ファイルが見つからなくなるまで繰り返す
Do While strFilename <> ""
' 行を加算
lngRow = lngRow + 1 ' 先頭は1行目
' A列にファイル名をセット
Cells(lngRow, 1).Value = strFilename
' 次のファイル名を取得
strFilename = Dir()
Loop
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
№ | 概略説明 |
---|---|
① |
処理を行なうフォルダパスを受け取ります。 「modFolderPicker2」はフォルダ名・ファイル名受け取り用に当サイトで作成した汎用機能で、「フォルダの参照(ダウンロード)」で説明しています。 |
② |
指定フォルダの先頭のファイル名を取得します。 |
③ |
ファイル名が受け取れなくなるまで繰り返します。 ループ内では受け取ったファイル名をシートのA列に行番号を加算して格納し、 次のファイル名を受け取ります。 |
'***************************************************************************************************
' ファイル一覧の取得(含むサブフォルダ) Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft Scripting Runtime
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'14/11/03(1.00)新規作成
'20/02/27(1.10)*.xlsm化、コード整理、他
'***************************************************************************************************
Option Explicit
'***************************************************************************************************
' ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :SearchFolders
'* 機能 :ファイル一覧の取得(含むサブフォルダ)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年11月03日
'* 作成者 :井上 治
'* 更新日 :2020年02月27日
'* 更新者 :井上 治
'* 機能説明:全体処理(ルートフォルダを指定して探索を開始)
'* 注意事項:サンプルなのでエラー処理は行なっていません
'***************************************************************************************************
Sub SearchFolders()
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim cntFolder As Long ' フォルダ数カウンタ
Dim cntFile As Long ' ファイル数カウンタ
Dim strRootFolder As String ' ルートフォルダ
'-----------------------------------------------------------------
' ルートとなるフォルダの指定(※modFolderPicker2.bas)
strRootFolder = modFolderPicker2.FolderDialog("ルートフォルダを指定して下さい。")
' 未指定は終了
If strRootFolder = "" Then Exit Sub
' 処理開始
Cells.ClearContents
Set objFso = New FileSystemObject
'-----------------------------------------------------------------
' ルートフォルダから探索開始
Call GP_FolderProc(objFso.GetFolder(strRootFolder), 0, 0, cntFolder, cntFile)
'-----------------------------------------------------------------
Set objFso = Nothing
' 処理完了(結果表示)
MsgBox "処理が完了しました。" & vbCr & vbCr & _
"フォルダ数=" & cntFolder & vbCr & _
"ファイル数=" & cntFile, vbInformation
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_FolderProc
'* 機能 :フォルダ単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = フォルダ(Object)
'* Arg2 = シート上の行(Long) ※Ref参照
'* Arg3 = シート上の列(Long)
'* Arg4 = フォルダ数カウンタ(Long) ※Ref参照
'* Arg5 = ファイル数カウンタ(Long) ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月25日
'* 作成者 :井上 治
'* 更新日 :2020年02月27日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:本処理は再帰動作
'***************************************************************************************************
Private Sub GP_FolderProc(ByVal objFolder As Folder, _
ByRef lngRow As Long, _
ByVal lngCol As Long, _
ByRef cntFolder As Long, _
ByRef cntFile As Long)
'-----------------------------------------------------------------------------------------------
Dim objSubFolder As Folder ' サブフォルダ
Dim objFile As File ' ファイル
'-----------------------------------------------------------------
' 現在フォルダをシート上に表示
cntFolder = cntFolder + 1 ' 参照フォルダ数を加算
lngRow = lngRow + 1 ' 行を加算
lngCol = lngCol + 1 ' カラムを加算
Cells(lngRow, lngCol).Value = "[" & objFolder.Name & "]"
'-----------------------------------------------------------------
' ■先ずサブフォルダを探索
For Each objSubFolder In objFolder.SubFolders
' フォルダ単位処理(再帰呼び出し)
Call GP_FolderProc(objSubFolder, lngRow, lngCol, cntFolder, cntFile) ' ※
Next objSubFolder
'-----------------------------------------------------------------
lngCol = lngCol + 1 ' カラムを加算
' ■本フォルダの各ファイルをシート上に表示
For Each objFile In objFolder.Files
cntFile = cntFile + 1 ' 参照ファイル数
lngRow = lngRow + 1 ' 行を加算
With objFile
' ファイル名+(最終更新日時+ファイルサイズ)
Cells(lngRow, lngCol).Value = .Name & _
" (" & .DateLastModified & " " & Format(.Size, "#,##0") & "Bytes)"
End With
Next objFile
' 参照OBJECTを破棄
Set objFolder = Nothing
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
'***************************************************************************************************
' ファイル一覧の取得(含むサブフォルダ)② Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft Scripting Runtime
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'05/09/08(1.00)新規作成
'14/11/03(1.10)*.xlsm化
'19/10/28(1.11)64ビット版対応
'20/02/27(1.12)記述整理、他
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsLine1 As String = "│" ' 表示接続線①
Private Const g_cnsLine2 As String = "├─" ' 〃 ②
Private Const g_cnsLine3 As String = "└─" ' 〃 ③
'---------------------------------------------------------------------------------------------------
' GetSystemTimeで使用する構造体
Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
' API
#If VBA7 Then
' ■システム時刻取得
Private Declare PtrSafe Sub GetSystemTime Lib "KERNEL32.dll" _
(lpSystemTime As SYSTEMTIME)
#Else
' ■システム時刻取得
Private Declare Sub GetSystemTime Lib "KERNEL32.dll" _
(lpSystemTime As SYSTEMTIME)
#End If
'---------------------------------------------------------------------------------------------------
' 全体保持変数
Private g_tblSwLine(1 To 256) As Byte ' つなぎ線有無FLG
Private g_tblLastRow(1 To 256) As Long ' カラム別最終フォルダ行
Private g_lngMaxCol As Long ' 最終カラム
'***************************************************************************************************
' ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :SearchFolders2
'* 機能 :ファイル一覧の取得(含むサブフォルダ)②
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2005年09月08日
'* 作成者 :井上 治
'* 更新日 :2020年02月27日
'* 更新者 :井上 治
'* 機能説明:全体処理(ルートフォルダを指定して探索を開始)
'* 注意事項:サンプルなのでエラー処理は行なっていません
'***************************************************************************************************
Sub SearchFolders2()
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim cntFolder As Long ' フォルダ数カウンタ
Dim cntFile As Long ' ファイル数カウンタ
Dim objStrTime As SYSTEMTIME ' 処理開始時間
Dim objEndTime As SYSTEMTIME ' 処理終了時間
Dim strRootFolder As String ' ルートフォルダ
'-----------------------------------------------------------------
' ルートとなるフォルダの指定(※modFolderPicker2.bas)
strRootFolder = modFolderPicker2.FolderDialog("ルートフォルダを指定して下さい。")
' 未指定は終了
If strRootFolder = "" Then Exit Sub
' 処理開始
Cells.ClearContents
' 処理開始時刻の受領
Call GetSystemTime(objStrTime)
Set objFso = New FileSystemObject
'-----------------------------------------------------------------
' ルートフォルダから探索開始
Call GP_FolderProc2(objFso.GetFolder(strRootFolder), 0, 0, cntFolder, cntFile)
'-----------------------------------------------------------------
Set objFso = Nothing
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
' 処理終了時刻の受領
Call GetSystemTime(objEndTime)
' 処理完了(結果表示)
MsgBox "処理が完了しました。" & vbCr & vbCr & _
"フォルダ数=" & Format(cntFolder, "#,##0") & _
", ファイル数=" & Format(cntFile, "#,##0") & vbCr & _
"(処理時間=" & Format(FP_SumProcSec(objStrTime, objEndTime), "#,##0.000") & "秒)", _
vbInformation
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_FolderProc2
'* 機能 :フォルダ単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = フォルダ(Object)
'* Arg2 = シート上の行(Long) ※Ref参照
'* Arg3 = シート上の列(Long)
'* Arg4 = フォルダ数カウンタ(Long) ※Ref参照
'* Arg5 = ファイル数カウンタ(Long) ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日 :2005年09月08日
'* 作成者 :井上 治
'* 更新日 :2020年02月27日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:本処理は再帰動作
'***************************************************************************************************
Private Sub GP_FolderProc2(ByVal objFolder As Folder, _
ByRef lngRow As Long, _
ByVal lngCol As Long, _
ByRef cntFolder As Long, _
ByRef cntFile As Long)
'-----------------------------------------------------------------------------------------------
Dim objSubFolder As Folder ' サブフォルダ
Dim objFile As File ' ファイル
Dim lngCol2 As Long ' シート上の列(WORK)
Dim lngCol3 As Long ' シート上の列(WORK)
Dim lngRow2 As Long ' シート上の行(WORK)
Dim cntFile2 As Long ' ファイル数カウンタ(WORK)
'-----------------------------------------------------------------
' 現在フォルダをシート上に表示
cntFolder = cntFolder + 1 ' 参照フォルダ数を加算
lngRow = lngRow + 1 ' 行を加算
lngCol2 = 1
' つなぎ線処理(手前のカラムに縦線を引く)
Do While lngCol2 < lngCol
' 要縦線か
If g_tblSwLine(lngCol2) = 1 Then
Cells(lngRow, lngCol2).Value = g_cnsLine1 ' │
End If
' 次の列へ
lngCol2 = lngCol2 + 1
Loop
' 有効列か
If lngCol >= 1 Then
' 有効列か
If g_tblLastRow(lngCol) <> 0 Then
' 直前のフォルダから本行前まで縦線を引く
Cells(g_tblLastRow(lngCol), lngCol).Value = g_cnsLine2 ' ├─
lngRow2 = g_tblLastRow(lngCol) + 1
Do While lngRow2 < lngRow
Cells(lngRow2, lngCol).Value = g_cnsLine1 ' │
' 次の行へ
lngRow2 = lngRow2 + 1
Loop
End If
Cells(lngRow, lngCol).Value = g_cnsLine3 ' └─
g_tblLastRow(lngCol) = lngRow
g_tblSwLine(lngCol) = 0
End If
lngCol = lngCol + 1 ' カラムを加算
Cells(lngRow, lngCol).Value = "[" & objFolder.Name & "]"
' つなぎ線処理(要縦線判定スイッチセット)
g_tblSwLine(lngCol) = 1
If g_lngMaxCol < lngCol Then g_lngMaxCol = lngCol
For lngCol2 = lngCol To g_lngMaxCol
g_tblLastRow(lngCol2) = 0
Next lngCol2
'-----------------------------------------------------------------
' ■先ずサブフォルダを探索
For Each objSubFolder In objFolder.SubFolders
' フォルダ単位処理(再帰呼び出し)
Call GP_FolderProc2(objSubFolder, lngRow, lngCol, cntFolder, cntFile)
Next objSubFolder
'-----------------------------------------------------------------
' ■本フォルダの各ファイルをシート上に表示
lngCol2 = lngCol
lngCol = lngCol + 1 ' カラムを加算
cntFile2 = cntFile
For Each objFile In objFolder.Files
' つなぎ線処理(直前のフォルダから本行前まで縦線を引く)
If g_tblLastRow(lngCol2) <> 0 Then
Cells(g_tblLastRow(lngCol2), lngCol2).Value = g_cnsLine2 ' ├─
lngRow2 = g_tblLastRow(lngCol2) + 1
Do While lngRow2 <= lngRow
Cells(lngRow2, lngCol2).Value = g_cnsLine1 ' │
' 次の行へ
lngRow2 = lngRow2 + 1
Loop
g_tblLastRow(lngCol2) = 0
End If
cntFile = cntFile + 1 ' 参照ファイル数を加算
lngRow = lngRow + 1 ' 行を加算
' つなぎ線処理(手前のカラムに縦線を引く)
lngCol3 = 1
Do While lngCol3 < lngCol2
' 要縦線か
If g_tblSwLine(lngCol3) = 1 Then
Cells(lngRow, lngCol3).Value = g_cnsLine1 ' │
End If
' 次の列へ
lngCol3 = lngCol3 + 1
Loop
With objFile
' ファイル名+(最終更新日時+ファイルサイズ)
Cells(lngRow, lngCol2).Value = g_cnsLine2 ' ├─
Cells(lngRow, lngCol).Value = .Name & _
" (" & .DateLastModified & " " & Format(.Size, "#,##0") & "Bytes)"
End With
Next objFile
' ファイルが追加されたか
If cntFile > cntFile2 Then
Cells(lngRow, lngCol2).Value = g_cnsLine3 ' └─
End If
' 参照OBJECTを破棄
Set objFolder = Nothing
End Sub
'***************************************************************************************************
'* 処理名 :FP_SumProcSec
'* 機能 :処理秒数の算出
'---------------------------------------------------------------------------------------------------
'* 返り値 :処理秒数(Double)
'* 引数 :Arg1 = 開始日時(SYSTEMTIME)
'* Arg2 = 終了日時(SYSTEMTIME)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年12月02日
'* 作成者 :井上 治
'* 更新日 :2017年12月02日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:終了日時≧開始日時であること、開始:終了間で日付が変わるケースは同月内のみ対応
'***************************************************************************************************
Private Function FP_SumProcSec(ByRef objStrTime As SYSTEMTIME, _
ByRef objEndTime As SYSTEMTIME) As Double
'-----------------------------------------------------------------------------------------------
Const cnsSecByDate As Double = 86400 ' 1日の秒数
Const cnsSecByHour As Double = 3600 ' 1時間の秒数
Const cnsSecByMinute As Double = 60 ' 1分の秒数
Dim dblStrTime As Double ' 開始日時(シリアル値)
Dim dblEndTime As Double ' 終了日時(シリアル値)
'-----------------------------------------------------------------
' 開始日時(シリアル値)
With objStrTime
dblStrTime = .wDay * cnsSecByDate
dblStrTime = dblStrTime + .wHour * cnsSecByHour
dblStrTime = dblStrTime + .wMinute * cnsSecByMinute
dblStrTime = dblStrTime + .wSecond
dblStrTime = dblStrTime + .wMilliseconds / 1000
End With
'-----------------------------------------------------------------
' 終了時刻(シリアル値)
With objEndTime
dblEndTime = .wDay * cnsSecByDate
dblEndTime = dblEndTime + .wHour * cnsSecByHour
dblEndTime = dblEndTime + .wMinute * cnsSecByMinute
dblEndTime = dblEndTime + .wSecond
dblEndTime = dblEndTime + .wMilliseconds / 1000
End With
'-----------------------------------------------------------------
FP_SumProcSec = dblEndTime - dblStrTime
End Function
'----------------------------------------<< End of Source >>----------------------------------------