Total Commander

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

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

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

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

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

With WScript.Arguments
  On Error Resume Next
  List = .Item(0)
  P    = .Item(1)
  Ext  = .Item(2)
  If .Count > 3 Then Filt = .Item(3)
  If Len(List) > 0 And .Count < 3 Then
    MsgBox  "Не выполнено условие:" & vbnewline & "минимальное число параметров - 3",_
    vbExclamation, "       Рекурсивная пофайловая упаковка"
    Wscript.Quit
  End If
End With

If Err.Number > 0 Then
  MsgBox  "Не выбраны элементы для упаковки!", vbExclamation,_
  "         Рекурсивная пофайловая упаковка"
  Wscript.Quit
End If

Set Dict = CreateObject("Scripting.Dictionary")
  Exts = "7Z | 7ZIP | ZIP | RAR | GZIP | BZIP2 | XZ | EXE | WIM"
  For Each E in Split(Exts, " | ")
    Dict.Add Trim(E), ""
  Next
  If Not Dict.Exists(Ucase(Ext)) Then
    MsgBox "Указанное расширение """ & UCase(Ext) & """ не поддерживается!" & vbnewline &_
    vbnewline & "Список поддерживаемых расширений:" & vbnewline & Exts, vbExclamation,_
    "                    Рекурсивная пофайловая упаковка"
    WScript.Quit
  End If
Set Dict = Nothing

Set Args = CreateObject("Scripting.Dictionary")
  For Each A In WScript.Arguments
    i = i + 1
    Args.Add i, A
    If i > 4 Then S = S & " " & A
  Next
Set Args = Nothing

Dim WSH
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
SZIP = WSH.ExpandEnvironmentStrings("%COMMANDER_PATH%\Utils\Arch\7z.exe")
RAR  = WSH.ExpandEnvironmentStrings("%COMMANDER_PATH%\Utils\Arch\rar.exe")

With FSO.OpenTextFile(WScript.Arguments(0), 1)
  Do While Not .AtEndOfStream
    F = Trim(.ReadLine)
    If F > vbNullString Then
      If FSO.FolderExists(F) Then
        ForFolder FSO.GetFolder(F)
      Else ForFile F
      End If
    End If
  Loop
  .Close
End With

WSH.Popup "Упаковка завершена!", 1.4 , "Результат", 64
Set FSO = Nothing
Set WSH = Nothing
WScript.Quit

Sub ForFolder(Folder)
  Dim N
  For Each N In Folder.SubFolders
    ForFolder N
  Next
  For Each N In Folder.Files 
    ForFile N
  Next
End Sub

Sub ForFile(File)
  If Len(Filt) > 0 Then
    For Each Fi in Split(Filt,",")
      If StrComp(Fi,FSO.GetExtensionName(File),1) = 0 Then Run File
    Next
  Else Run File
  End If
End Sub

Sub Run(FF)
  If InStr(P, ":") > 0 Then
    Path = P
  Else
    PP = FSO.GetFile(FF).ParentFolder & "\" & P
    If FSO.FolderExists(PP) Then
      Path = PP & "\"
    Else Path = FSO.CreateFolder(PP) & "\"
    End If
  End If
  If Not FSO.FileExists(Path & FSO.GetBaseName(FF) & "." & Ext) Then
    Name = FSO.GetBaseName(FF) & "." & Ext
  Else
    Name = FSO.GetFileName(FF) & "." & Ext
    Const M = 1
    Do While FSO.FileExists(Path & Name)
      l = l + 1
      If l < 10^M Then
        PostFix = Right(String(M, "0") & l, M)
      Else
        PostFix = l
      End If
      Name = FSO.GetFileName(FF) & " (" & PostFix & ")." & Ext
    Loop
  End If
  If LCase(Ext) <> "rar" Then
    Pr = SZIP
    Param = "a """ & Path & Name & """ """ & FF & """" & S
  Else
    Pr = RAR
    Param = "a -ep1" & S & " """ & Path & Name & """ """ & FF & """"
  End If
  WSH.Run """" & Pr & """ " & Param, 0, True
End Sub

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

WSH.Popup "Упаковка завершена!", 1.4 , "Результат", 64

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

MsgBox "    Упаковка завершена!", vbInformation, "      Рекурсивная пофайловая упаковка"

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

  If P <> "1" Then Path = P 

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

  If InStr(P, ":") > 0 Then Path = P 

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

  If InStr(P, ":") = 0 Then Path = F1.ParentFolder & "" & P

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

Set Dict = CreateObject("Scripting.Dictionary") 
  Exts = "7Z | 7ZIP | ZIP | RAR | GZIP | BZIP2 | XZ | EXE | WIM"
  For Each E in Split(Exts, " | ")
    Dict.Add LCase(Trim(E)), "" 
  Next 
  If Not Dict.Exists(Lcase(Ext)) Then 
    MsgBox "Указанное расширение """ & UCase(Ext) & """ не поддерживается!" & vbnewline &_ 
    vbnewline & "Список поддерживаемых расширений:" & vbnewline & Exts, vbExclamation,_ 
    "                    Рекурсивная пофайловая упаковка" 
    WScript.Quit 
  End If