フォルダ内整理･･･

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


■ 例によって･･･

おきつね鯖から

DateClassificator_Installer.exe
　を ダウンロードして実行すると導入される。
利用方法は、整理したいフォルダを デスクトップに出来たアイコンにドロップする。 以上

■ 動作としては･･･

フォルダ内ファイルの ファイル名と作成日時情報を 全て配列変数へ格納。
その変数内データを基に、ファイルを１つずつ処理する。

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

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

誤操作による起動への対応も施してあるので、利用で不便するコトはナイと思う。
ただ、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↓↓↓ *********************************************************