多重フォルダ解消（子フォルダまで）.vbs

Option Explicit
' 多重フォルダ解消（子フォルダまで）
'
' 最上位の子フォルダから、フォルダ内がフォルダ一つでなくなるまで、階層を繰り上げる
'

Dim fso, arg_dir, root_dir, d, topfolder
If WScript.Arguments.Count = 0 Then
    WScript.Echo("usage: this.vbs <フォルダ>")

    WScript.Quit()
End If

Set fso = CreateObject("Scripting.FileSystemObject")

arg_dir = WScript.Arguments.Unnamed(0)
If (fso.FolderExists(arg_dir) <> false) Then
    If ( IsDriveLetter(arg_dir) ) Then
        WScript.Echo("ドライブ名は指定できません: """ & arg_dir & """")
    Else
        Set root_dir = fso.GetFolder(arg_dir)
        For Each d in root_dir.SubFolders
            topfolder = GetTopFolder(d.Path)
            If ( 0 <> StrComp(d.Path, topfolder, vbTextCompare) ) Then
                Dim tmp, f, deldir
                Dim post_dir
                Set post_dir = Nothing

                Set f  = fso.GetFolder(topfolder)
                For Each tmp In d.SubFolders
                    Set deldir = tmp
                Next

                For Each tmp in f.SubFolders
                    If (fso.FolderExists( d.Path & "\" & tmp.Name)) Then
                        msgbox "trace1:" & d.Path & "     \     " & tmp.Name
                        tmp.Name = "_" & tmp.Name
                        Dim tmp_path
                        tmp_path = d.Path & "\" & tmp.Name
                        fso.MoveFolder tmp.path, d.Path & "\"
                        Set post_dir = fso.GetFolder(tmp_path)
                    Else
                        fso.MoveFolder tmp.path, d.Path & "\"
                    End If
                Next
                For Each tmp in f.Files
                    fso.MoveFile tmp.path, d.Path & "\"
                Next
                If fso.FolderExists(deldir.Path) Then
                    fso.DeleteFolder deldir.Path, true
                End If
                If Not (post_dir Is Nothing) Then
                    post_dir.Name = Mid(post_dir.Name, 2)
                End If

                Set deldir = Nothing
                Set f = Nothing
                Set tmp = Nothing
                Set post_dir = Nothing
                Set root_dir = Nothing
            End If
        Next
    End If
End If
Set fso = Nothing


Function IsAlpha(c)
    Dim x
    x = Asc(c)
    IsAlpha = CBool( (65<=x And x<=90) Or (97<=x And x<=122) )
End Function

Function IsDriveLetter(p)
    If ( ((3=Len(p)) And (":\"=Right(p,2)) And IsAlpha(Left(p,1))) _
            Or ((2=Len(p)) And (":"=Right(p,1)) And IsAlpha(Left(p,1))) ) Then
        IsDriveLetter = True
    Else
        IsDriveLetter = False
    End If
End Function

Function GetTopFolder(d)
    Dim tmp, f, dirs
    Set f = fso.GetFolder(d)
    Set dirs = f.SubFolders
    If (f.Files.Count = 0 And dirs.Count = 1) Then
        For Each tmp In dirs
            GetTopFolder = GetTopFolder(tmp.Path)
        Next
    Else
        GetTopFolder = d
    End If
    Set dirs  = Nothing
    Set f = Nothing
End Function