Total Commander

Код: Выделить всё

'==========================================================================
' Создание отдельных архивов для каждой вложенной папки в выделенных папках

' В параметрах вызова из TC должно быть прописано:
' %L
'==========================================================================

Dim FSO, WS, FoldList, Fold, Fold1, WinRar, Command, Command1, Command2, ArchKeys, FullArchName
Set FSO      = CreateObject("Scripting.FileSystemObject")
Set WS       = CreateObject("WScript.Shell")
Set FoldList = FSO.OpenTextFile(WScript.Arguments(0), 1)

WinRar   = "D:\Program Files\WinRAR\WinRAR.exe"  ' Путь к WinRAR.exe
Command1 = " A"                                  ' "Добавить файлы в архив"
Command2 = " U"                                  ' "Обновить файлы в архиве"
ArchKeys = " -r -ep1 -ibck"                      ' Ключи:
                                                 '   "Рекурсивно с вложенными папками"
                                                 '   "Исключить из пути базовую папку"
                                                 '   "Запустить WinRAR как фоновый процесс в системном лотке"
Do While Not FoldList.AtEndOfStream
  FoldPath = FoldList.ReadLine
  Set Fold = FSO.GetFolder(FoldPath)
  For Each Fold1 in Fold.SubFolders
    FullArchName = FoldPath & Fold1.Name & ".rar"
    If Not FSO.FileExists(FullArchName) Then
      Command = Command1
    Else
      Command = Command2
    End If
    WS.run """" & WinRar & """" & Command & ArchKeys & " """ & FullArchName & """ """ & Fold1.Path & "\""", , True
  Next
Loop

Set FSO      = Nothing
Set WS       = Nothing
Set Fold     = Nothing
Set Fold1    = Nothing
Set FoldList = Nothing
WScript.Quit

Код: Выделить всё

'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
' Упаковать каждый файл или содержимое каждой папки в отдельный архив

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

' Примеры:
'  1) %WL "%T" zip
'  2) %WL "%T" RAR
'  3) %WL "%P" exe "" -sfx7zCon.sfx
'  4) %WL "%P" rar "" -m5 -s -rr5p -pPASSWORD -ag_DD.MM.YY
'  5) %WL "%T" ZIP "" -mx9 -mm=Deflate -mfb=258 -mcu=on -pSECRET 
'  6) %WL "%T" 7Z txt,doc,bat,cmd, -mx9 -m0=LZMA2 -ssw -pПАРОЛЬ

' Автор - Flasher ©
'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
' Установка и проверка параметров:
With WScript.Arguments
  On Error Resume Next
  List = .Item(0) : Path = .Item(1) : Ext  = .Item(2)
  If Err.Number > 0 Then
    MsgBox  "Не выбраны элементы для упаковки!", 48, Space(25) & "Пакетная упаковка"
    Wscript.Quit
  End If : On Error GoTo 0
  L = vbnewline : C = .Count : If C > 3 Then Filt = .Item(3)
  If Len(List) > 0 And .Count < 3 Then
    MsgBox  "Не выполнено условие:" & L & "минимальное число параметров - 3",_
    vbExclamation, Space(23) & "Пакетная упаковка"
    Wscript.Quit
  End If
  If C > 5 Then
    For i = 5 to C - 1 : S = S & " " & .Item(i) : Next
  End If
End With : Const M = 1
' Проверка поддержки указанного расширения архива:
Exts = "7Z | 7ZIP | ZIP | RAR | GZIP | BZIP2 | XZ | EXE | WIM"
If InStr(Exts, Ucase(Ext)) = 0 Then
  MsgBox "Указанное расширение """ & UCase(Ext) & """ не поддерживается!" & L &_
  L & "Список поддерживаемых расширений:" & L & Exts, 48,_
  Space(38) & "Пакетная упаковка" : WScript.Quit
End If
' Объявление объектов и переменных с путями к утилитам:
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim WSH : Set WSH = CreateObject("WScript.Shell")
SZIP = "%COMMANDER_PATH%\Utils\7-Zip\7z.exe"
RAR  = "%COMMANDER_PATH%\Plugins\arc\rar.exe"
' Построение цикла для упаковки массива элементов:
For Each F in Split(FSO.GetFile(List).OpenAsTextStream(1, -1).ReadAll, L)
  If F > vbNullString Then
    If FSO.FileExists(F) Then
      If Len(Filt) > 0 Then
        Ext1 = LCase(FSO.GetExtensionName(F))
        If Ext1 <> "" Then
          If InStr(LCase(Filt), Ext1 & ",") > 0 Then Filtr F, SZIP, RAR, Ext, Path, S
        End If
      Else Filtr F, SZIP, RAR, Ext, Path, S
      End If
    Else
      Name = FSO.GetFileName(F) & "." & Ext : Str = ""
      If LCase(Ext) <> "rar" Then
        If Len(Filt) > 0 Then
          For Each E in Split(Filt, ",") : Str = Str & " """ & F & """*." & LCase(E) : Next
        Else Str = " """ & F & """*"
        End If
        WSH.Run """" & SZIP & """ a """ & Path & Name & """ """ & F & """*\" & Str & S, 0, True
      Else
        Set PF = FSO.GetFolder(F)
        For Each FF in PF.SubFolders : Period Str, FF, RAR, S, Path, Name : Next
        For Each FF in PF.Files
          If Len(Filt) > 0 Then
            Ext1 = LCase(FSO.GetExtensionName(FF))
            If Ext1 <> "" Then
              If InStr(LCase(Filt), Ext1 & ",") > 0 Then Period Str, FF, RAR, S, Path, Name
            End If
          Else Period Str, FF, RAR, S, Path, Name
          End If
        Next : If Str <> "" Then WSH.Run """" & RAR & """ a -ep1 -ri15" & S & " """ & Path & Name & """" & Str, 0, True
      End If
    End IF
  End If
Next
' Вывод сообщения и выход:
WSH.Popup "Упаковка завершена!", 1.4, "Результат", 64
Set FSO = Nothing : Set WSH = Nothing : WScript.Quit

' Процедура упаковки файлов:
Sub Filtr(FN, SZ, RA, Ex, P, K)
  Nm = FSO.GetBaseName(FN) & "." & Ex : Name = Nm : l = 0
  Do While FSO.FileExists(P & Name)
    l = l + 1 : If l < 10^M Then PostFix = Right(String(M, "0") & l, M) Else PostFix = l
    Name = Nm & " (" & PostFix & ")." & Ext
  Loop
  If LCase(Ex) <> "rar" Then
    Pr = SZ : Param = "a """ & P & Name & """ """ & FN & """" & K
  Else
    Pr = RA : Param = "a -ep1" & K & " """ & P & Name & """ """ & FN & """"
  End If : WSH.Run """" & Pr & """ " & Param, 0, True
End Sub
' Процедура упаковки папок в RAR по частям, исходя из ограничения длины комстроки:
Sub Period(St, FP, RR, K, Dir, NF)
  St = St & " """ & FP & """"
  If Len(St) > 1900 Then
    WSH.Run """" & RR & """ a -ep1 -ri15" & K & " """ & Dir & NF & """" & St, 0, True
    St = ""
  End If
End Sub