ファイル吸い出しVBScript

ファイルの管理、整理に便利…かも？

あるフォルダ配下にある全ファイルを、そのあるフォルダの一つ上の階層のフォルダに移動し、
フォルダ構造を無くして1フォルダ内に纏めるスクリプトです。
例えば、「hoge」というフォルダの中に「docs」というフォルダがあり、
「docs」の中に「txt」「xls」「csv」というフォルダがあって、それぞれにファイルが入ってた場合、
テキストファイルとエクセルファイルとCSVファイルが「hoge」フォルダへ移動し、「docs」フォルダは無くなります。

同じファイル名があった場合、2ファイル目以降は「元のファイル名＋半角スペース＋連番」の形でリネームします。
iTunesとかみたいな感じですね。
はじめは上書きするかどうか質問する形で書いてたんですが、
上書きしなかった場合移動する側のファイルが消えてしまうことになるなぁと思って、この形にしました。

使い方は、フォルダをVBSファイルへドラッグします。例によって右クリックの「送る」に登録しとくと便利だと思います。
フォルダの複数選択も可能です。

右クリックの「送る」へ登録する方法はコチラ

'SuckingOut.vbs
Option Explicit

Const SCRIPT_NAME = "吸い出しスクリプト"
Dim objArgs, fs
Dim i, cnt
Set objArgs = WScript.Arguments
Set fs = CreateObject("Scripting.FileSystemObject")
If objArgs.Count = 0 Then WScript.Quit
For i = 0 to objArgs.Count - 1
    If fs.FolderExists(objArgs(i)) Then
        SuckingOut objArgs(i), fs.getParentFolderName(objArgs(i)) & "\"
        fs.DeleteFolder objArgs(i)
        cnt = cnt + 1
    End If
Next
Set fs = Nothing
If cnt Then MsgBox "完了しました。", , SCRIPT_NAME

Sub SuckingOut(dpath, pdpath)
    Dim fs, F, d
    Dim cnt1, cnt2
    Dim new_fpath
    Set fs = CreateObject("Scripting.FileSystemObject")
    Do
        cnt1 = 0
        For Each F In fs.GetFolder(dpath).Files
            If fs.FileExists(pdpath & F.Name) Then
                cnt2 = 1
                '同名ファイルの処理
                Do 
                    new_fpath = pdpath & fs.getBaseName(F.Name) & " " & CStr(cnt2) & "." & fs.getExtensionName(F.Name)
                    If fs.FileExists(new_fpath) = False Then
                        fs.MoveFile F.Path, new_fpath
                        Exit Do
                    End If
                    cnt2 = cnt2 + 1
                Loop
            Else
                fs.MoveFile F.Path, pdpath
            End If
            cnt1 = cnt1 + 1
        Next
        If cnt1 = 0 Then Exit Do
    Loop
    For Each d In fs.GetFolder(dpath).SubFolders
        SuckingOut d.Path, pdpath
    Next
    Set fs = Nothing
End Sub

Windows自動処理のためのWSHプログラミングガイド