Создание списка со структурой выбранных элементов

'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
' Создание списка со структурой выбранных в панели элементов

' Условия:
'  1) vbs-файл сохранить в Юникоде: UTF16 LE c ВОМ или UTF16 BE без ВОМ
'  2) путь запуска - пустой
'  3) выбрать для просмотра моноширинный шрифт
'     например: Courier New, Lucida Console

' Параметры (! - обязательный): 
'  1. <путь к списку элементов> (!)
'  2. "<путь назначения>\" (!) (если установить "", то - активный каталог);
'  3. <не/указывать размер файлов в байтах: 0/1> (!)
'  4. <не/указывать дату модификации файлов 0/1> (!)
'  5. <не/указывать время модификации файлов 0/1> (!)
'  6. <сортировать файлы по имени/размеру/дате и времени: 0/1/2> (!)
'  7. <сортировать файлы по возрастанию/убыванию: 0/1> (!)
'  8. <отступ - кол-во пробелов> (!)
'  9. <фильтр-список расширений файлов>  разделитель - запятая
' 10. "<относительный путь к редактору для открытия файла>"

' Примеры:
'  1) %WL "" 1 1 0 1 1 2 jpg,jpeg,png,gif
'  2) %WL "%T" 1 1 1 2 1 3 "" "Utils\Akelpad\Akelpad.exe"

' Автор - Flasher ©
'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••

With WScript.Arguments
  On Error Resume Next
  List = .Item(0) : Path = .Item(1) : FSize = .Item(2) : FDate = .Item(3) : FTime = .Item(4)
  FSort = .Item(5) : Rev = .Item(6) : Indent = .Item(7) : If .Count > 8 Then Filt = .Item(8)
  If .Count > 9 Then Editor = .Item(9)
  If Len(List) > 0 And .Count < 8 Then Errors "Не выполнено условие:" & vbnewline &_
  "минимальное число параметров - 8", 16
  If Err.Number > 0 Then Errors "Не выбраны элементы!", 5 : On Error goto 0
  For Arg = 2 to 6 : If .Item(Arg) < 0 Or .Item(Arg) > 2 Then Nums = Nums & ", " & Arg + 1
  Next : If Nums <> "" Then Errors "Для следующих параметров" & vbnewline &_
  "значения не верны: " & Mid(Nums, 2), 17
End With : Summ = FSize + FDate + FTime : If FTime Then FDate = 1

Sub Errors(Desc, SCount)
  MsgBox  Desc, vbExclamation, Space(SCount) & "Создание списка элементов" : Wscript.Quit
End Sub

Select Case FSort
  Case 1 Sort = "FSize" : Case 2 Sort = "FDate"
End Select : If Rev Then Sort = Sort & " DESC" : If Summ = 0 Then Sort = "Name"

Set FSO = CreateObject("Scripting.FileSystemObject")
Dim WSH : Set WSH = CreateObject("WScript.Shell")
Set Coll = CreateObject("Scripting.Dictionary")
Set Dict = CreateObject("ADODB.Recordset")
CD = WSH.CurrentDirectory : TrgDepth = UBound(Split(CD, "\"))
Coll.Add 1, 0 : SetLocale(1049) : Dict.Fields.Append "Name", 200, 255
If FSize Then _
Sz = "   Размер в байтах" : SpSz = "   " & String(15, "¯") : Dict.Fields.Append "FSize", 139, 15
If FDate Then _
FD = "   Дата"   : SpFD = "   " & String(10, "¯") : Dict.Fields.Append "FDate", 135, 22
If FTime Then FT = Space(8) & "Время"  : SpFT = "  "  & String(8,  "¯") : Dict.Open

Mass = Split(FSO.GetFile(List).OpenAsTextStream(1,-1).ReadAll, vbNewLine)
Last = Mass(Ubound(Mass) - 1)
For Each F in Mass
  If Trim(F) > vbNullString Then
    If FSO.FolderExists(F) Then ForFolder FSO.GetFolder(F), SS Else Indent = 0 : ForFile F, SS, 1
  End If
Next : Count = Coll.Item(1) : If Count < 15 Then Count = 15
If Count > 15 Then Spc = Space(Count - 15)

For Each St in Split(SS, vbCr)
  Sr = "" : St1 = "" : T2 = "" : Sr1 = "" : St2 = "" : T1 = InStr(St, vbTab)
  If T1 Then
    Sr = Left(St, T1 - 1) : St1 = Mid(St, T1 + 1) : T2 = InStr(St1, vbTab)
    If FSize Then St = Sr & Space(Count - Len(Sr) + 3) & St1
    If FDate Then
      If FSize Then
        Sr1 = Left(St1, T2 - 1) : St2 = Mid(St1, T2 + 1)
        St = Sr & Space(Count - Len(Sr) + 3) & Sr1 & Space(18-Len(Sr1)) & DateValue(St2)
      Else St = Sr & Space(Count - Len(Sr) + 3) & DateValue(St1) : End If
      If FTime Then
        If FSize Then TV = TimeValue(St2) Else TV = TimeValue(St1)
        St = St & "  " & TV
      End If
    End If
  End If : Text = Text & vbCr & St
Next

If Text <> "" Then
  If Right(Path, 1) <> "\" Then Path = Path & "\"
  Name = FSO.GetFileName(CD) : If Name = "" Then Name = "Drive " & Left(CD, 1)
  NewName = Path & Name & ".txt" : FN = NewName : n = 0 : Const M = 0
  Do While FSO.FileExists(NewName)
    n = n + 1 : If n < 10^M Then PFix = Right(String(M, "0") & n, M) Else PFix = n
    NewName = Path & FSO.GetBaseName(FN) & " (" & PFix & ")." & FSO.GetExtensionName(FN)
  Loop
  FSO.OpenTextFile(NewName, 2, True, -1).Write "Имя папки/файла" & Spc & Sz & FD & FT &_
  vbnewline & String(Count, "¯") & SpSz & SpFD & SpFT & Text
  If Editor <> "" Then WSH.Exec "%COMMANDER_PATH%\" & Editor & " """ & NewName & """"
End If : Set FSO = Nothing : Set WSH = Nothing : Set Dict = Nothing
Set Coll = Nothing : WScript.Quit

Sub ForFolder(Folder, S)
  Depth = UBound(Split(Folder.Path, "\")) - TrgDepth - 1
  FName = Space(Depth*Indent) & Folder.Name & "\"
  S = S & vbNewLine & FName : Length = Len(FName)
  If Length > Coll.Item(1) Then Coll.Item(1) = Length
  For Each Fl In Folder.SubFolders : ForFolder Fl, S : Next
  Set Files = Folder.Files
  Max = Files.Count
  If Max Then
    For Each Fl In Files 
      i = i + 1 : ForFile Fl, "", Depth
      If i = Max And Dict.RecordCount Then
        Cr = vbCr : Dict.Sort = Sort : If Right(S, 1) = vbCr Then Cr = ""
        S = S & Cr & Dict.GetString : i = 0 : Dict.CancelBatch
      End If
    Next
  End If
End Sub

Sub ForFile(File, S, FDepth)
  If Filt <> "" Then
    For Each Fi in Split(Filt,",")
      If StrComp(Fi, FSO.GetExtensionName(File), 1) = 0 Then FileProc File, S, FDepth : Exit For
    Next
  Else FileProc File, S, FDepth
  End If
  If FSO.GetParentFolderName(File) = CD And File = Last Then
    Dict.Sort = Sort : Cr = vbCr : If Right(S, 1) = vbCr Then Cr = ""
    S = S & Cr & Dict.GetString : i = 0 : Dict.CancelBatch
  End If
End Sub

Sub FileProc(FF, S, FlDepth)
  Set A = FSO.GetFile(FF)
  Str = Space(Indent + FlDepth*Indent) & A.Name : Length = Len(Str)
  If Length > Coll.Item(1) Then Coll.Item(1) = Length
  Dict.AddNew : Dict("Name")  = Str
  If FSize Then Dict("FSize") = CCur(A.Size)
  If FDate Then Dict("FDate") = CStr(A.DateLastModified) : Dict.Update
End Sub