第１回：FSOで写真の更新日時を調べる。スマホの写真をまとめたい。Twitterレビュー後の追記。
FileSysytemObjectを使って、写真の作成、更新、アクセス日時を調べる
過去記事で、PowerShellを使って写真の作成日時を元にフォルダを作成し格納するというShellを作ったことがありました。
ExcelにはＦＳＯがあり、「作成、更新、アクセス日時」を調べることができるので同じようなものができることに気づき、作ってみました。
PowerShellは書き方が違うので、慣れないためExcelで作った方が馴染みやすいと思い作ってみました。
写真が増えたのは、子どもの写真を撮りすぎて整理の収集がつかなくなったからです。
アルバム作る時に「年、月」で整理していれば、成長の過程がわかりやすいかなという感じです。
子どもの将来のためにも整理してあげよう、という多少の親心をみせます。
１ 閲覧対象者
大量の写真を作成日時で「年、月」ごとのフォルダにざっくり仕分けしたい人
２ 得られる効果
大量の写真ファイルが、
「年、月」ごとに仕分けされて、格納される。
処理イメージ
処理イメージの動画Gifです。
— かずやん_VBAerLv.５ (@y8bV4ty1wbkTjPd) 2020年12月30日
これを作ったきっかけは、スマホで撮った子どもの写真を整理するためです！
これで処理イメージを持っていただけたらと！ pic.twitter.com/yxbI87MmUH
３ 設計
２のフォルダに写真を格納する。
１のエクセルマクロ実行。
３のフォルダに「年、月」ごとに写真が格納される。
＊２，３のフォルダが１のエクセルのPATHになければ、２，３フォルダを作成する（Workbook_Open）。
４ ＶＢＡの処理を解説
ＦＳＯで、作成、更新、アクセス日時」を調べる。
まずは、写真の「作成、更新、アクセス日時」をMsgboxに表示してみます。
結果
処理コード
Sub 写真の最終日時を取得() Dim fso As Object Set fso = CreateObject("scripting.filesystemobject") Set f = fso.GetFile("ファイルPATH\＊.jpg") MsgBox " 作 成 日 時 ：" & FileDateTime("ファイルPATH\＊.jpg") & vbCrLf & _ "最終更新日時 ：" & f.DateLastModified & vbCrLf & _ "最終アクセス日時：" & f.DateLastAccessed picture_date = FileDateTime("ファイルPATH\＊.jpg"") picture_year = Year(picture_date) picture_month = Month(picture_date) picture_day = Day(picture_date) picture_hour = Hour(picture_date) picture_minute = Minute(picture_date) picture_second = Second(picture_date) Set f = Nothing End Sub
解説
作 成 日 時 → FileDateTime("ファイルPATH\＊.jpg") ＊ＦＳＯは関係ない。
最終更新日時 → f.DateLastModified
最終アクセス日時 → f.DateLastAccessed
読んでそのままで、わかりやすいです。
Msgboxの下のコードは、作成日時から「年、月、日、時、分、秒」が取得できることを表しています。
つまり、ここの「年、月」で条件分岐すればフォルダーを作成し写真を格納する処理が作れるということです。
本題の写真を「年、月」ごとに格納するマクロ
ＦＳＯで作成日時の「年、月」から、フォルダがあるか調べる。
フォルダがあれば、写真をそのフォルダに移動する。
フォルダがなければ、フォルダを作って写真をそのフォルダに移動する。
これだけです。
noteにはフォルダがアップできなかったので、このExcelを開いたら、同じPathにフォルダを作成するようにしました。（ThisWorkBookに処理記述）。
ＶＢＡのコード
標準モジュール 年月別にフォルダを作成
Sub 年月別にフォルダを作成() '処理時間の計測----------------------------------------------------------------------------------- Dim startTime As Double Dim endTime As Double Dim processTime As Double startTime = Timer '__________________________________________________________________________________________________ Dim targetFolder As String Dim loadFolder As String targetFolder = ThisWorkbook.Path & "\" & "写真を仕分けて格納" loadFolder = ThisWorkbook.Path & "\" & "処理対象写真を格納する" Dim fso_lord, fso_traget As Object Set fso_lord = CreateObject("scripting.filesystemobject") Set fso_traget = CreateObject("scripting.filesystemobject") Set f = fso_lord.GetFolder(loadFolder) Set f2 = fso_traget.GetFolder(targetFolder) Set fc = f.Files 'ファイル数が０なら処理終了。 If fc.Count = 0 Then MsgBox "対象ファイルなし": Exit Sub '主処理 For Each f1 In fc '.jpgを処理。 If f1.Name Like "*.jpg" Or f1.Name Like "*.JPG" Then '年、月を取得する。 picture_date = FileDateTime(f1) picture_year = Year(picture_date) picture_month = Month(picture_date) FolderName = picture_year & "年" & picture_month & "月" SearchFolder = targetFolder & "\" & FolderName 'フォルダが存在するか調べる If fso_traget.FolderExists(SearchFolder) Then '存在する場合は格納処理 fso_lord.MoveFile f1, SearchFolder & "\" Else '存在しない場合は、フォルダを作って格納処理 'フォルダ作成 fso_traget.createfolder SearchFolder 'ファイルを格納 fso_lord.MoveFile f1, SearchFolder & "\" End If End If Next f1 '処理時間の計測----------------------------------------------------------------------------------- endTime = Timer processTime = endTime - startTime MsgBox "end 処理時間＝" & Round(processTime / 60, 0) & "分" & Round(processTime Mod 60, 0) & "秒" '__________________________________________________________________________________________________ End Sub
ThisWorkBook フォルダを作成するコード
Private Sub Workbook_Open() Dim fso As Object Set fso = CreateObject("scripting.filesystemobject") SearchFolserPath = ThisWorkbook.Path Search1 = "処理対象写真を格納する" Search2 = "写真を仕分けて格納" 'ファルダが存在するか調べる If fso.FolderExists(SearchFolserPath & "\" & Search1) Then 'フォルダ有、処理なし。 Else 'フォルダなし、フォルダを作る fso.createfolder SearchFolserPath & "\" & Search1 MsgBox "フォルダ：「処理対象写真を格納する」を作成しました。" End If If fso.FolderExists(SearchFolserPath & "\" & Search2) Then 'フォルダ有、処理なし。 Else 'フォルダなし、フォルダを作る fso.createfolder SearchFolserPath & "\" & Search2 MsgBox "フォルダ：「写真を仕分けて格納」を作成しました。" End If End Sub
５ 作ってみての感想
意外と簡単にできました。Pwershellはあんまり使わないので、VBAで作った方が親しみがわきます。
約２００枚の写真を１３秒くらいで仕分けできました。割と早いので、処理速度は問題なしかと。
６ Twitterでレビューしてもらったら…
この記事の内容を「#VBAの悩みはVBAerに聞け」にUPしたところ以下の指摘点がありました。
１ fsoは概念上１つでよいはず
２ 制御コードの重複
３ 拡張子判断の正規化(JPG)
４ fsoを使わなかったらどういうコードになるか（番外編）
それぞれ、解説していきます。
１ fsoは概念上１つでよいはず
ツッコミのあったのは以下のコードです。
Dim fso_lord As Object, fso_traget As Object Set fso_lord = CreateObject("scripting.filesystemobject") Set fso_traget = CreateObject("scripting.filesystemobject")
変数をfso_lord、fso_traget２つ宣言しています。そしてこの２つをFSOとしてSETしています。
この部分が１つでいんじゃね？？というご質問でした。
該当する処理部分は以下のコード
'フォルダが存在するか調べる If fso_traget.FolderExists(SearchFolder) Then '存在する場合は格納処理 fso_lord.moveFile f1.Path, SearchFolder & "\" Else '存在しない場合は、フォルダを作って格納処理 'フォルダ作成 fso_traget.createfolder SearchFolder 'ファイルを格納 fso_lord.moveFile f1.Path, SearchFolder & "\" End If
フォルダが存在するか調べる場合はfso_tragetを使い、ファイルを格納（moveFile）するときは、fso_lordを使っていました。
しかし、FSOの構造を考えると変数は１つでいいのです。実際に以下のように、変数fso_tragetを、fso_lordに変更しても処理は変わりません。
変数fso_traget → fso_lordに変更したコード。
'フォルダが存在するか調べる If fso_lord.FolderExists(SearchFolder) Then '存在する場合は格納処理 fso_lord.moveFile f1.Path, SearchFolder & "\" Else '存在しない場合は、フォルダを作って格納処理 'フォルダ作成 fso_lord.createfolder SearchFolder 'ファイルを格納 fso_lord.moveFile f1.Path, SearchFolder & "\" End If
これでも同じように動きます。それはなぜか？？
結論は、FileSystemObjectはファイルシステムを抽象化したもので、フォルダを抽象化したものではない。ファイルシステムは１つです。
この回答が一番しっくりきました。
つまり、１つしかないファイルシステムに対して複数変数宣言する意味あんの？？ということです。回答としては、「無い」です。
実際、変数fso_lordだけでもちゃんと処理ができていますｗ
２ 制御コードの重複
ツッコミがあったのは以下のコードです。
'フォルダが存在するか調べる If fso_lord.FolderExists(SearchFolder) Then '存在する場合は格納処理 fso_lord.moveFile f1.Path, SearchFolder & "\" Else '存在しない場合は、フォルダを作って格納処理 'フォルダ作成 fso_lord.createfolder SearchFolder 'ファイルを格納 fso_lord.moveFile f1.Path, SearchFolder & "\" End If
つまりは、「fso_lord.moveFile f1.Path, SearchFolder & "\"」が重複してるよ！ということを質問されていました。
最初は、サブルーチン化すればいいのかなと思ったのですが、答えはもっと簡単なことでした。
ポイントは、「fso_lord.moveFile f1.Path, SearchFolder & "\"」この処理はＩＦ文の中に書く必要ないんじゃない！？フォルダだけ作って、ファイルの格納処理はＩＦ文外でやればいいじゃんということでした。
修正後のコード
'フォルダが存在するか調べる If fso_traget.FolderExists(SearchFolder) = False Then '存在しない場合は、フォルダ作成 fso_traget.createfolder SearchFolder End If 'ファイルを格納 fso_lord.moveFile f1, SearchFolder & "\"
非常にコードがすっきりしました。
重複して記述していた「fso_lord.moveFile f1, SearchFolder & "\"」の処理も１行のみになりました。
３ 拡張子判断の正規化(JPG)
ツッコミがあったのは以下のコードです。
If f1.Name Like "*.jpg" Or f1.Name Like "*.JPG" Then
小文字のjpgと大文字のJPGに対応させるために「Or」を使っています。しかし、これはLCase、UCaseを使えば「Or」を使う必要はないとのことでした。
改善後のコード（大文字にして判定）
If UCase(myFile.Name) Like "*.JPG" Then
これで「Or」を使う必要はなくなりました。
４ fsoを使わなかったらどういうコードになるか（番外編）
これは時間のある時に考えます(;^ω^)
以上の質問を受けた上での最終コード
Option Explicit Dim fso As Object Sub PhotoOrganize() '変数定義------------------------------------------------------------ Dim targetFolder As String: targetFolder = ThisWorkbook.Path & "\" & "写真を仕分けて格納" Dim loadFolder As String: loadFolder = ThisWorkbook.Path & "\" & "処理対象写真を格納する" Dim targetCount As Long Dim picture_date As String, picture_year As String, picture_month As String Dim FolderName As String, SerachFolder As String '定義終了____________________________________________________________ Set fso = CreateObject("scripting.filesystemobject") 'ファイル数が０なら処理終了。 If fso.GetFolder(loadFolder).Files.Count = 0 Then MsgBox "対象ファイルなし": Exit Sub '主処理 Dim myFile As Object For Each myFile In fso.GetFolder(loadFolder).Files '.jpgを処理。 If UCase(myFile.Name) Like "*.JPG" Then '年、月を取得する。 picture_date = FileDateTime(myFile) picture_year = Year(picture_date): picture_month = Month(picture_date) FolderName = picture_year & "年" & picture_month & "月" SearchFolder = targetFolder & "\" & FolderName Call Fnc_MoveFile(myFile.Path, SearchFolder & "\") End If Next End Sub
Fnc_MoveFile部のコード
Function Fnc_MoveFile(moveFolder As String, beforFolder As String) 'フォルダが存在するか調べる If fso.FolderExists(beforFolder) = False Then 'フォルダ作成 fso.createfolder beforFolder End If 'ファイル格納処理 fso.moveFile moveFolder, beforFolder End Function
非常にすっきりしたコードになりました。ご質問いただいた方々ありがとうございました。m(_ _"m)
