【VBScript】フォルダ内のファイルを更新日付でフォルダ分けする

フォルダ内に溜まったファイルを手動で振分するのが面倒なのでVBSで自動で年月日フォルダに振分されるスクリプトを作成しました。 システム管理者の作業にはログファイルの管理などがあるかと思いますが、１つのフォルダに出力され続けるものが多いです。 ファイルが増えてくると目的のファイルを見つけにくくなるため整理する必要があります。大量のファイルを人力で振分するのは大変なので自動処理できるようにしました。

画像ファイルの整理などにも便利です。

【欲しかった機能】

フォルダドロップ

ファイルのあるフォルダ内にフォルダを作成

ファイルはコピーして移動（元ファイルを削除する場合は「.copy」を「.move」にする）

処理中の表示

Option Explicit

Dim Fs, sTargetFolder, oTarget, oFile
Dim sFdc, strYear, strMonth, strDay
Dim strYearFolder, strMonthFolder, strDayFolder
Dim Args  
'IE の宣言と初期化
Dim ie
initializeIe()
updateMsg "処理を開始します..."

Set Args = WScript.Arguments

If Args.Count <> 1 Then '処理できるのは１フォルダのみ
    WScript.Echo "当スクリプトに対象となる１フォルダをドラッグ&ドロップして処理を実行してください。"
    WScript.Quit    'スクリプトを終了
End If

'フォルダ判別
With CreateObject("Scripting.FileSystemObject") '以下の処理はEnd WithまでScripting.FileSystemObjectを使用
    If .FolderExists(Args(0)) = False Then  'ドラッグされたものを解析
        WScript.Echo "フォルダが見つかりません。" & vbCrLf & "あるいはフォルダではありません。"
        closeIe()
        WScript.Quit
    End If
End With

Set Fs = WScript.CreateObject("Scripting.FileSystemObject")
For Each sTargetFolder In Args
If Fs.FolderExists(sTargetFolder) Then
 updateMsg (sTargetFolder & " のファイルを整理します。")
 Set oTarget=Fs.GetFolder(sTargetFolder)
 For Each oFile In oTarget.Files
  updateMsg (oFile)
  ' 移動先ディレクトリの存在チェックと作成
  ' YYYY年\MM月\DD日 という形式でフォルダを作成する。
  sFdc = oFile.DateLastModified
  strYear = mid(sFdc,1,4) 
  strMonth = mid(sFdc,6,2)
  strDay = mid(sFdc,9,2)
  strYearFolder = sTargetFolder & "\" & strYear & "年"
  If Not Fs.FolderExists(strYearFolder) Then
   Fs.CreateFolder(strYearFolder)
  End if
  strMonthFolder = strYearFolder & "\" & strMonth & "月"
  If Not Fs.FolderExists(strMonthFolder) Then
   Fs.CreateFolder(strMonthFolder)
  End If 
  'strDayFolder = strMonthFolder & "\" & strDay & "日"  '年月日でフォルダを作成する場合はここを有効にする
  'If Not Fs.FolderExists(strDayFolder) Then
   'Fs.CreateFolder(strDayFolder)
  'End If

  ' ファイルの移動
  updateMsg ("  -> " & Fs.BuildPath(strDayFolder, oFile.Name))
  If Fs.FileExists(Fs.BuildPath(strDayFolder, oFile.Name)) Then
   WScript.echo("  すでにファイルが存在しています。(" & Fs.BuildPath(strDayFolder, oFile.Name) & ")")
   '何もしない。
  Else
   'oFile.Move(strDayFolder & "\") '元データを削除する場合はここを有効にする
   'oFile.copy(strDayFolder & "\") '年月日でフォルダを作成する場合はここを有効にする
   oFile.copy(strMonthFolder & "\") '年月でフォルダを作成する場合はここを有効にする
   
  End If
 Next
End If
'WScript.echo("  移動しました。")
 WScript.echo("  コピーしました。")
' IE を終了させスクリプトを閉じる
closeIe()
WScript.Quit
Next
'------------------------------------------------------------------------------------------------------------------
 ' IE の初期化
Sub initializeIe()
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .Navigate("about:blank")
    .ToolBar = False
    .StatusBar = False
    ' 幅・高さの設定
    .Width = 900
    .Height = 200
    ' 画面右上に配置する。"parentWindow.screen" はパスカルケースで書くと認識されない
    .Top = 0
    .Left = .Document.parentWindow.screen.Width - 900
    .Document.Charset = "UTF-8"
    .Visible = True
    .Document.Title = "スクリプト実行中"
  End With
End Sub
'------------------------------------------------------------------------------------------------------------------
' メッセージを IE に追記する
' 
' 引数のメッセージを IE の最終行に追記する。
' 最終行が表示されるようにスクロール位置を最下部に設定する。
Sub updateMsg(value)
  With ie
    .Document.Body.innerHTML = .Document.Body.innerHTML & value & "<br>"
    .Document.Script.setTimeout "javascript:scrollTo(0," & .Document.Body.ScrollHeight & ");", 0
  End With
End Sub

' IE を終了する
Sub closeIe()
  ie.Quit
  Set ie = Nothing
End Sub