フォルダ配下のファイル作成日時一覧取得マクロ

フォルダ配下のファイル作成日時を一覧で取得出来るマクロを作成したいのですが、
どなたか教えて頂けますでしょうか。

イメージは以下のマクロを改良する形でファイルの情報を取得したいです。
※以下は、フォルダ情報を取得するマクロとなっております。

おそらく以下の形と組み合わせれば、作成出来ると思うのですが、Excelマクロに詳しくないため、
どなたか詳しい方にご教授頂けますと幸いです。
http://www.relief.jp/itnote/archives/018022.php
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub GetFolder()

' GetFolder() sak 2010/12/08 フォルダ１階層のみ取得
' GetFolder() sak 2011/01/06 表示しないフォルダ名をはじくことができるよう準備
' GetFolder() sak 2011/03/13 階層の深さを指定できるようにした

'
Dim strPath As String
Dim strFName As String

Dim intLevel As Integer

Dim i As Integer
Dim j As Integer
Dim k As Integer

'
strPath = InputBox("調べたいフォルダを絶対パスで入力してください。", _
"フォルダ一覧作成マクロ", "c:test")

strFName = InputBox("探したいフォルダ名を入力（入力無しなら全て）", _
"フォルダ一覧作成マクロ", "")

intLevel = InputBox("階層の深さを入力(カレントが0)", _
"フォルダ一覧作成マクロ", "5")

'
Range("A1").Value = "GetFolder()"
Range("C1").Value = strPath
Range("D1").Value = "フォルダ一覧作成"
Range("B2").Value = "名前"
Range("C2").Value = "フルパス名"
Range("D2").Value = "サイズ(KB)"
Range("E2").Value = "更新年月日"
Range("F2").Value = "作成年月日"
Range("G2").Value = "最終アクセス年月日"
Range("H2").Value = "種類"

Range("B1").ColumnWidth = 40
Range("C1").ColumnWidth = 40
Range("D1").ColumnWidth = 6
Range("E1").ColumnWidth = 16
Range("F1").ColumnWidth = 16
Range("G1").ColumnWidth = 16
Range("H1").ColumnWidth = 20
With Range("B2:H2")
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
ActiveSheet.Cells(3, 2) = " "
'Range("A3", ActiveCell.SpecialCells(xlLastCell)).ClearContents
Range("A3", ActiveCell.SpecialCells(xlLastCell)).Delete Shift:=xlUp
Range("A3").Select
ActiveWindow.FreezePanes = True
i = 3
j = 0
k = 1
GetFolder2 strPath, strFName, i, j, k, intLevel
End Sub
Sub GetFolder2(strPath, strFName, i, j, k, intLevel)
Dim WSname As String
Dim WSvalue As String
On Error GoTo myError
'Application.ScreenUpdating = False '画面を固定する事により高速化します
Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFld = objFs.GetFolder(strPath)
'i = i + 1 ' サブフォルダ名で１行使う
For Each objfl In objFld.SubFolders
WSvalue = objfl.Name
Application.StatusBar = objfl.Name 'http://officetanaka.net/excel/vba/tips/tips13.htm
If InStr(objfl.Name, strFName) > 0 Then
If InStr(objfl.Name, "隠しフォルダ") = 0 Then '一時的に追加 2011/01/06
With ActiveSheet
WSname = objfl.ParentFolder.Path & "\" & WSvalue 'hyperlink用sak
.Cells(i, 2).Select
.Hyperlinks.Add Anchor:=Cells(i, 2), _
Address:=WSname, ScreenTip:=WSname, TextToDisplay:=objfl.Name
.Cells(i, 2).Font.Size = "11"
.Cells(i, 3) = objfl.ParentFolder.Path & "\" & objfl.Name
'.Cells(i, 4) = Int(objfl.Size / 1024) 'フォルダの計算をさせたいときはコメント外す,フォルダの容量が大きいとExcelがハングアップしたように見えるので注意
.Cells(i, 5) = objfl.DateLastModified
.Cells(i, 6) = objfl.DateCreated
.Cells(i, 7) = objfl.DateLastAccessed
.Cells(i, 8) = objfl.Type
End With
i = i + 1
j = j + 1
End If '一時的に追加 2011/01/06
End If
Next
'MsgBox "k: " & k & ",intLevel: " & intLevel 'debug
If k < intLevel Then
k = k + 1
For Each objsub In objFld.SubFolders
GetFolder2 objsub.Path, strFName, i, j, k, intLevel
Next
Else
k = 1
End If
k = 1
Range("B1").Value = j
Application.StatusBar = False 'http://officetanaka.net/excel/vba/tips/tips13.htm
Exit Sub
myError:
MsgBox objfl & vbCrLf & i & vbCrLf & j & vbCrLf & k & _
"エラー番号:" & Err.Number & vbCrLf & _
"エラーの種類:" & Err.Description, vbExclamation
Resume Next
End Sub

No.5 ベストアンサー 回答者： WindFaller 回答日時： 2017/03/31 21:14

作ってみました。

確か、そのプロパティの名称のことを、「ドキュメント概要プロパティ」とか言っていたと思います。やってみると、取れないものも出てきます。何かファイルのトラブルなのかもしれません。

今回は、
Microsoft Developer Support OLE File Property Reader (Dso)というツールが必要になります。

https://www.microsoft.com/en-us/download/details …
Microsoft Developer Support OLE File Property Reader 2.1 Sample (KB 224351)

をインストールしてください。インストールして、
ツール－参照設定でインストールに成功していれば、
DSO OLE Document Properties Reader 2.1
というのがありますから、それを選択してください。
そのファイルについては、DSOでぐぐってみてください。

出力は以下のように3つにしました。
今のところ実験的な要素が強いです。
2番目が概要プロパティから抜き出したもの、3番目はFSOから、抜き出したものです。
FileDateTimeは、順序の問題なのかうまくいきません。

ファイル名　　作成日/Prop　　作成日/File

'//
Const TARGETFOLDER As String = "C:\Users\[UserName]\Documents\Test1\"
Sub GetFileNameAndCreateDateInProp()
'//Office ファイルから、作成日を抜き出すマクロ//
'//要：DsoFileSetup_KB224351_x86.exe

　Dim myFolder As String
　Dim FName As String
　Dim i As Long, k As Long
　Dim objFS As Object, objFile As Object
　Dim DSO As DSOFile.OleDocumentProperties　　'参照設定
　Set DSO = New DSOFile.OleDocumentProperties
　Dim buf As Variant
　Set objFS = CreateObject("Scripting.FilesystemObject")
　
　If Application.CountA(ActiveSheet.UsedRange) > 1 Then
　　If MsgBox("シートを削除します、よろしいですか？", vbOKCancel) = vbCancel Then Exit Sub
　　ActiveSheet.UsedRange.Clear
　End If
　'--------Start ------
　Cells(1, 2).Resize(, 3).Value = Array("ファイル名", "作成日/Prop", "作成日/File")
　myFolder = TARGETFOLDER
　If Right$(myFolder, 1) <> "\" Then myFolder = myFolder & "\"

　k = 2　'初期行
　FName = Dir(myFolder & "*.xls?", vbNormal)
　Do While FName <> ""
　　If FName <> "." And FName <> ".." Then
　　　If (GetAttr(myFolder & FName) And vbNormal) = vbNormal Then
　　　　　Cells(k + i, 2).Value = FName
　　　　　DSO.Open myFolder & FName
　　　　　buf = DSO.SummaryProperties.DateCreated
　　　　　Cells(k + i, 3).Value = buf
　　　　　Set objFile = objFS.GetFile(myFolder & FName)
　　　　　Cells(k + i, 4).Value = objFile.DateCreated
　　　　　DoEvents
　　　　　DSO.Close
　　　　　i = i + 1
　　　　End If
　　　End If
　　　FName = Dir
　　Loop
　　MsgBox "Finish!", vbInformation
　End Sub

No.4 回答者： tatsu99 回答日時： 2017/03/31 20:56

現行のマクロへ追加する形です。

Sub GetFolder2(strPath, strFName, i, j, k, intLevel)
Dim WSname As String
Dim WSvalue As String
On Error GoTo myError
If k = 1 Then Call GetFiles(strPath, i) '追加①
'Application.ScreenUpdating = False '画面を固定する事により高速化します
・・・・
i = i + 1
j = j + 1
Call GetFiles(objfl.ParentFolder.Path & "\" & objfl.Name, i) '追加②
End If '一時的に追加 2011/01/06


Sub GetFolder2へ
①と②を追加します。

更に以下のプロシージャを、後に追加します。
Private Sub GetFiles(parentPath, i)
On Error GoTo myError
Set objFs = CreateObject("Scripting.FileSystemObject")
Set objfld = objFs.GetFolder(parentPath)
For Each objfl In objfld.Files
With ActiveSheet
.Cells(i, 2) = objfl.Name
.Cells(i, 3) = objfl.ParentFolder.Path & "\" & objfl.Name
.Cells(i, 4) = Int(objfl.Size / 1024)
.Cells(i, 5) = objfl.DateLastModified
.Cells(i, 6) = objfl.DateCreated
.Cells(i, 7) = objfl.DateLastAccessed
.Cells(i, 8) = objfl.Type
End With
i = i + 1
Next
Exit Sub
myError:
MsgBox parentPath & vbCrLf & objfl & vbCrLf & _
"エラー番号:" & Err.Number & vbCrLf & _
"エラーの種類:" & Err.Description, vbExclamation
Resume Next
End Sub

No.3 回答者： WindFaller 回答日時： 2017/03/31 19:29

>ただ、更新日時がどうも取得されてしまうようです。

>エクセルのプロパティ→詳細情報→作成日時で表示される作成日時を取得する方法が知りたいのです。
まず、「oFile.DateCreated」は、【作成日】に間違いありません。

できれば、それは最初にしてほしかったですね。

その、プロパティから抜き出すことは、質問で出しているコードや質問内容とは、違う内容です。それは、ファイルのプロパティではなく、内部のプロパティですから、基本的には開かないと取れません。これにWordが加わると、さらにややこしい内容になったように思います。Excelファイルを開いて取り出す以外には、VBAそのままでは不可能です。また、フォルダーは一層程度に留めたほうがよいです。

リンク先の2005年ぐらいでは、そんな大きな違いはなかったのですが、Excel2007以降のファイルの構造やセキュリティの問題で、最初に作った日は、大きく違ってしまいます。

肝心な私が、今、できるかどうかわかりません。
いずれにしても、もう一度返事はいたします。

No.2 回答者： WindFaller 回答日時： 2017/03/31 15:18

基本的には、これほど作り込んだものは、パッとみた感じ、とてもわからづらいです。

こちらも作ってみました。昔作ったものの手の直しです。一応、実用に耐えるものだと思っています。
なお、header という変数は、あまり意味がないものですから、無視してください。
このコードの最後に、「統一性が悪い」というのは、FileSystemObject なら、それを通したほうが、良いのではないかと思いました。


'//
Const TARGETFOLDER As String = "C:\Users\[UserName]\Documents\Test1\"
Dim objFS As Object
Dim header As Long '意味が薄い
Dim x As Long, y As Long
Const FOLCOLR As Integer = 3　'フォルダに色付け

Sub GetFileNameAndCreateDate()
　Dim myFolder As String
　Dim objFolder As Object
　If Application.CountA(ActiveSheet.UsedRange) > 5 Then
　If MsgBox("シートを削除します、よろしいですか？", vbOKCancel) = vbCancel _
　　Then Exit Sub
　ActiveSheet.UsedRange.Clear
　End If
　Set objFS = CreateObject("Scripting.FilesystemObject")
　'ファイル作成日時を一覧（構造的)

　x = 1: y = 1
　myFolder = TARGETFOLDER
　If Right$(myFolder, 1) <> "\" Then myFolder = myFolder & "\"

　Cells(x, y).Value = myFolder
　Cells(x, y).Font.ColorIndex = FOLCOLR

　x = x + 1: y = 1

　Set objFolder = objFS.GetFolder(myFolder)
　Call ShowFiles(header + y, objFolder.Files)
　Call ShowFolder(y, objFolder)

End Sub

Sub ShowFolder(ByVal header As Long, ByRef objFolder)
　Dim objSubs As Object, oSb
　Dim i As Long
　Dim eaFiles As Object

　Set objSubs = objFolder.Subfolders
　i = 1: y = i
　For Each oSb In objSubs
　　　Cells(x, header + y).Value = oSb.Name
　　　Cells(x, header + y).Font.ColorIndex = FOLCOLR
　　　x = x + 1
　　　Set eaFiles = oSb.Files
　　　Call ShowFiles(header + y, eaFiles)
　　　Call ShowFolder(header + y, oSb)
　　i = i + 1　　'この変数は利用はあっても、今は浮いている
　Next
End Sub
Sub ShowFiles(header, ByRef eaFiles)
　Dim ea
　Dim oFile
　For Each ea In eaFiles
　　Cells(x, header + 1).Value = ea.Name
　　Set oFile = objFS.getfile(ea.Path):
　　Cells(x, header + 2).Value = oFile.DateCreated
　　''Cells(x, header + 2).Value = FileDateTime(ea.Path) '←統一性が悪い
　　x = x + 1
　Next
End Sub

この回答へのお礼

ありがとうございます、フォルダ階層も取得出来てすごいです。
ただ、更新日時がどうも取得されてしまうようです。
エクセルのプロパティ→詳細情報→作成日時で表示される作成日時を取得する方法が知りたいのです。

以下コードのFileDateTimeをCreateObjectに変更したのですが、できませんでした。
※参考：https://oshiete.goo.ne.jp/qa/1310881.html
＝＝＝＝＝＝
Sub フォルダを指定してファイル名と最終更新日時の一覧を作成する()
　Dim fld As FileDialog
　Dim fd_path As String
　Dim fl_name As String
　Dim i As Long

　Set fld = Application.FileDialog(msoFileDialogFolderPicker)
　'キャンセル時にマクロ終了
　If fld.Show = 0 Then Exit Sub

　'フォルダのフルパスを変数に格納
　fd_path = fld.SelectedItems(1)

　'指定されたフォルダの一つ目のファイル名を取得
　fl_name = Dir(fd_path & "\*")
　If fl_name = "" Then MsgBox "ファイルが存在しません。": Exit Sub

　Worksheets.Add Before:=Sheets(1)
　
　Range("A1").Value = fd_path
　Range("A2").Value = "のファイル一覧"
　Range("A4").Value = "ファイル名"
　Range("B4").Value = "最終更新日時"

　i = 5
　ChDir fd_path & "\"　'カレントフォルダの変更
　Do Until fl_name = ""
　　Cells(i, "A").Value = fl_name
　　Cells(i, "B").Value = FileDateTime(fl_name)
　　i = i + 1
　　fl_name = Dir　'次のファイル名を取得
　Loop

　MsgBox Sheets(1).Name & "に一覧を作成しました。"

End Sub

お礼日時：2017/03/31 17:56

No.1 回答者： tatsu99 回答日時： 2017/03/31 11:08

これを実行するとF列に作成年月日が表示されますが、それでは、だめなのでしょうか？

この回答へのお礼

こちらはフォルダ階層の作成日時なので、ほしいのはファイルの作成日時なのです。

お礼日時：2017/03/31 17:57