2015/10/23

フォルダ内整理・・・

・・・ファイルの作成日時を基に、そのフォルダ内で 日付階層フォルダ別に仕分けるスクリプトなど。


■ 例によって・・・
おきつね鯖から
DateClassificator_Installer.exe
 を ダウンロードして実行すると導入される。
利用方法は、整理したいフォルダを デスクトップに出来たアイコンにドロップする。 以上
■ 動作としては・・・
フォルダ内ファイルの ファイル名と作成日時情報を 全て配列変数へ格納。
その変数内データを基に、ファイルを1つずつ処理する。

対象となるドロップしたフォルダ内に 対象ファイルの作成日付フォルダを作成し 移動させる。
この際、日付フォルダが無ければ 自動で作成しつつ処理が進められる。

ファイルは コピーではなく 移動しているだけ、ドライブ上の容量は ほぼ増えるコトがナイ。
ファイルの総数が数千に及ぶ場合などは、メモリに少し余裕が必要になる可能性はあるが、
殆どの環境で 日付別分類を実行出来るだろう。

誤操作による起動への対応も施してあるので、利用で不便するコトはナイと思う。
ただ、VBScriptである以上、中断する処理は含められていない。
処理開始確認Popupが表示された時点で、各位適宜判断し 利用して欲しい。
◆ 肝心のスクリプトはコンなカンジ。
■ DateClassificator.vbs/.vbe
'***** ↓↓↓ScriptTitle↓↓↓ ********************************************************* ' DateClassificator ' 指定フォルダ内ファイルを、作成日別に 対応する日付のフォルダへ格納します。 ' - Created by LazwardFox - ' Update ' Update 20151023 093228 - BackupNameCreateの処理を簡易化。 ' Release 20151023 060653 ' αRelease 20151023 055336 ' DevStart 20151023 013120 '***** ↓↓↓ Memo ↓↓↓ ************************************************************** '***** ↓↓↓ ObjectDecralations ↓↓↓ ************************************************* Option Explicit Dim My, MySh, Parameters, Fs Set My = WScript With My Set Parameters = .Arguments 'パラメーター取得 If Parameters.Count <= 0 Then 'パラメータなし起動の無効化 誤操作による起動を防止 .Quit End If Set MySh = .CreateObject("WScript.Shell") Set Fs = .CreateObject("Scripting.FileSystemObject") End With '***** ↓↓↓ConstructDecralations↓↓↓ ********************************************************* Const vbWq = """" ' 文字列データに ダブルクォーテーションを利用する為の変数。 '***** ↓↓↓AuthDecralations↓↓↓ ********************************************************* '***** ↓↓↓ValiableConstDecralations↓↓↓ ********************************************************* Dim Pc, Dummy Dim vbWCrLf vbWCrLf = vbCrLf & vbCrLf Dim strTitle, strRoot strTitle = Fs.GetBaseName(My.ScriptName) strRoot = Fs.GetParentFolderName(My.ScriptName) '***** ↓↓↓PublicDecralations↓↓↓ ********************************************************* '***** ↓↓↓Decralations↓↓↓ ********************************************************* ' --------------------------------------------------------- ' --------------------------------------------------------- '***** ↓↓↓MainRoutine↓↓↓ ********************************************************* On Error Resume Next Dim strFolder, strSourceFull, strDate, strMoved Dim objFiles, objFile Dim arTargets, inTargets, inTarget, arDates strFolder = Parameters(0) If Fs.FileExists(strFolder) Then MySh.Popup "指定の対象がフォルダではありません", , strTitle, 64 Else If FD2ar(strFolder, arTargets) Then If MySh.Popup("フォルダ" & vbWCrLf & strFolder & vbWCrLf & _ "に、格納されている全ファイルに対して、" & vbCrLf & _ "日付フォルダ別分類処理を開始しますか?", , strTitle, 65) = 2 Then MyQuit Else For Each inTargets in arTargets If TypeName(inTargets) = "Empty" Then Else strDate = Split(inTargets(1), " ")(0) strMoved = DateFolderCreate(strFolder, strDate) strMoved = Fs.BuildPath(strMoved, inTargets(0)) strSourceFull = Fs.BuildPath(strFolder, inTargets(0)) If Fs.FileExists(strMoved) Then strMoved = BackupNameCreate(strMoved) End If Fs.GetFile(strSourceFull).Move(strMoved) End If Next MySh.Popup Pc + 1 & "コのファイルの" & vbCrLf & "日付フォルダへの分類を完了しました。", , strTitle, 64 End If Else MySh.Popup "対象となるファイルが存在していません。", , strTitle, 64 End If End If MyQuit ' --------------------------------------------------------- ' --------------------------------------------------------- '***** ↓↓↓ CreatingFunctions ↓↓↓ ********************************************************* '***** ↓↓↓ LimitedFunctions ↓↓↓ ********************************************************* '***** ↓↓↓ GlobalFunctions ↓↓↓ *************************************************** '------------------------------------ ' BackupNameCreate ' ' - Created by LazwardFox - ' Update ' Update 20151023 093228 - 拡張子取得方法を簡易に。 ' Release 20151023 054622 - チェック機能ナシ。 ' DevStart 20151023 043855 Function BackupNameCreate(strTarget) Dim strName, strBaseName, strExtention, iResult strName = Fs.GetFileName(strTarget) strBaseName = Fs.GetBaseName(strTarget) 'strExtention = Fs.GetExtensionName(strTarget) 'iResult = strBaseName & " " & iDT(""," ","",0) & "." & strExtention strExtention = Replace(strName, strBaseName, "") iResult = strBaseName & " " & iDT(""," ","",0) & strExtention BackupNameCreate = Replace(strTarget, strName, iResult) End Function '------------------------------------ ' DateFolderCreate ' ' - Created by LazwardFox - ' Update ' Release 20151023 050528 ' DevStart 20151023 043855 Function DateFolderCreate(strRoot, strDates) Dim arDates, strFolder, iChk, strCN If Fs.FolderExists(strRoot) Then arDates = Split(strDates, "/") strFolder = strRoot For Each iChk In arDates strCN = Fs.BuildPath(strFolder, iChk) If Fs.FolderExists(strCN) Then Else Fs.CreateFolder strCN End If strFolder = strCN Next DateFolderCreate = strFolder Else DateFolderCreate = "" End If End Function '------------------------------------ ' FD2ar ' 文字列で指定されたフォルダ配下の ファイル と 日付情報 の 一覧を配列化 ' サブフォルダは対象外。 ' - Created by LazwardFox - ' Update ' Release 20151023 035155 ' DevStart 20151023 021836 Function FD2ar(strTarget, arResults) Dim objFiles, objFile, arTargets() FD2ar = Fs.FolderExists(strTarget) If FD2ar Then Set objFiles = Fs.GetFolder(strTarget).Files Pc = -1 For Each objFile in objFiles Pc = Pc + 1 Redim Preserve arTargets(Pc) arTargets(Pc) = Array(objFile.Name, objFile.DateCreated) Next If Pc => 0 Then arResults = arTargets Else FD2ar = False End If Else End If End Function '------------------------------------ ' MyQuit - 終了処理 ' - Created by LazwardFox - ' Update ' Release ' Update 20151021 042112 - ' βRelease 20120914 085236 ' DevStart 20120914 Function MyQuit() 'Set objMx = Nothing 'Set objSMTP = Nothing 'Set xmlHTTP = Nothing 'Set ShApp = Nothing Set Fs = Nothing Set MySh = Nothing My.Quit End Function '------------------------------------ 'iDT - 日時文字列 ないし 日/時配列取得 for VBScript '- Created by LazwardFox - ' Update 20090228 0458 変数宣言変更 ' Update 20090223 0959 時刻桁処理変更 ' Update 20090223 0253 Len記述忘れ修正 ' Update 20090223 0135 変数宣言忘れ修正 ' Update 20090210 0218 ' Update 20090210 0115 ' Release 20090209 2035 ' iDT ( ' dSplitter - DateSplitString (Normal - "/") ' ,dtSeparater - Date/Time SepaleteString (Normal - " ") ' ,tSplitter - TimeSplitString (Normal - ":") ' ,Control - 配列化 0 or 1 (Default - 1) ' ) Public Function iDT(dSplitter,dtSeparater,tSplitter,Control) Dim nX, nD, nS, strHMS, sResult 'Update 20090228 0458 nX = Now() nD = FormatDateTime(Date(),0) nS = ":" & Split(CStr(FormatDateTime(nX,3)),":")(2) 'Update 20090223 0951 strHMS = FormatDateTime(nX,4) & nS 'Update 20090223 0951 If tSplitter = ":" Then Else strHMS = Replace(strHMS,":",tSplitter) End If sResult = Cstr(Replace(nD,"/",dSplitter)) & "*" & strHMS If Control = 1 Then iDT = Split(sResult,"*") Else iDT = Replace(sResult,"*",dtSeparater) End If End Function '***** ↓↓↓ DebugFunctions ↓↓↓ ********************************************************* '***** ↓↓↓Memo↓↓↓ *********************************************************

0 件のコメント:

コメントを投稿