Total Commander Knowledge Base

Есть вопрос?

Поищите ответ в самой большой русскоязычной базе знаний по Total Commander!

Распаковка архивов

A: Универсальный vbs-скрипт распаковки архивов c поддерживаемыми утилитой 7z.exe (в составе пакета 7-zip) типами:
'•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
' Распаковка выбранных архивов и/или архивов в структуре выбранных каталогов
' в одноимённые папки рядом с архивами (при наличии в них более одного элемента)
' c автоматическим переходом в случае распаковки одного архива

' Условие: необходима текущая версия утилиты 7z.exe

' Параметры:
' 1. %WL (обязательный)
' 2. <расширения архивов (в т.ч. двойные) через "|"> ("" - все поддерживаемые)
' 3. <флаг распаковки одиночных элементов без подкаталогов: 1>
' 4. <пропустить/перезаписать существующие/переименовать извлекаемые файлы: s/a/u>
' 5. <флаг удаления удачно распакованных архивов: 1>
' 6. <флаг распаковки зашифрованных архивов: 1>

' Примеры: %WL | %WL "" 1 | %WL 7z|7zip|arj|bzip2|rar|tar.bz2|zip | %WL "" 1 s 0 1

Option Explicit : Dim Z7, PWTrue
'••••••••• Путь к утилите 7z.exe •••••••••
Z7 = "%COMMANDER_PATH%\Utils\7-Zip\7z.exe"
'•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••• Автор: Flasher © •••

Dim A, C, Filt, One, Mode, Del, Passw, List, WSS, FSO, Pass
Set A = WSH.Arguments : C = A.Count: If C = 0 Then WSH.Quit
If C > 1 Then Filt = LCase(A(1)) : If C > 2 Then One = A(2)
If C > 3 Then Mode = "-ao" & A(3): If C > 4 Then Del = A(4): If C > 5 Then Passw = A(5)
List = A(0): Set WSS = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
If InStrRev(LCase(WSH.FullName), "wscript.exe") Then
  Dim Par, Pars
  For Par = 1 To C - 1
    If A(Par) <> "" Then
      Pars = Pars & " " & A(Par)
    ElseIf C - 1 > Par Then Pars = Pars & " """""
    End If
  Next : WSS.Run "cscript.exe //NoLogo """ & WSH.ScriptFullName & """ " & List & Pars,0
  If FSO.GetDrive(FSO.GetDriveName(WSH.FullName)).IsReady Then WSH.Sleep 500 : WSH.Quit
End If : Dim Reg, Prn, ShA, Fi, Ch, Cn, It : Set Reg = New Regexp
If FSO.FileExists(FSO.GetSpecialFolder(1) & "\oleprn.dll") Then _
Set Prn = CreateObject("OlePrn.OleCvt.1")
Set ShA = CreateObject("Shell.Application")
Reg.IgnoreCase = True : Reg.Pattern = "^(001|7z(|ip)|a|apm|arj?|bz(|ip)2|cab|cpio|ch[iqmw]" &_
"|cramfs|deb|dmg|docx?|e(sd|pub|xe|xt[234]?)|fat|gz(|ip)|hfsx?|hx[sirqw]|ihex|img|iso|jar|" &_
"li[bt]|l(zh|ma)|lha|mbr|ms(i|lz|sp)|mub|n(si|tf)s|od[st]|qcow(|2c?)|r00|rar|rpm|pkg|ppmd|" &_
"ppt|squashfs|scap|swm|t[agx]z|tar|tbz2?|u(d|efi)f|vdi|vhd|vmdk|wim|x(ar|lsx?|pi|z)|z|zipx?)$"

With FSO.OpenTextFile(List,,,-1)
  Do : Fi = Trim(.ReadLine)
    If Fi <> "" Then If FSO.FileExists("\\?\" & Fi) Then _
    ForFile Fi, Ch, It, Cn Else ForFolder Fi, Ch, It, Cn
  Loop Until .AtEndOfStream : .Close
End With
If Ch > 1 Then WSS.Popup "Распаковка завершена!", 1.4 , " Результат", 64
If Ch = 1 Then If FSO.FileExists(It) Or FSO.FolderExists(It) Then _
If Cn > 1 And FSO.FolderExists(It) Then It = FSO.GetParentFolderName(It) End If :_
WSS.Exec """%COMMANDER_EXE%"" /A /S /O /L=""" & Replace(It, "\\?\", "") & """"
If FSO.FileExists(List) Then FSO.DeleteFile List

Sub ForFile(Arch, T, F1, Sum)
  Dim Ext, BN, Ex, Exe, Item : Ext = LCase(FSO.GetExtensionName(Arch))
  BN = FSO.GetBaseName(Arch) : Ex  = LCase(FSO.GetExtensionName(BN))
  Ex = Len(Ex) * InStr("|" & Filt & "|", "|" & Ex & "." & Ext & "|")
  If (Filt = "" Or Ex Or InStr("|" & Filt & "|", "|" & Ext & "|")) And Reg.Test(Ext) Then
    PWTrue = 1 : If Passw = 1 Then GetPass Arch, "" : If PWTrue = 0 Then Exit Sub
    Set Exe = WSS.Exec("%comspec% /c chcp 1251|""" & Z7 & """ l -slt" &_
              " """ & Arch & """ -sccUTF-8 -p" & Pass & "|find /v ""\""")
    Dim i, Itm : For i = 1 To 8 : Exe.StdOut.SkipLine : Next : Sum = 0
    If  InStr(Exe.StdOut.ReadLine, "Errors:") = 1 Then Exit Sub
    Do: Itm = Exe.StdOut.ReadLine
      If i <> 1 Then
        If Itm = "----------" Then i = 1
      ElseIf InStr(Itm, "Path = ") = 1 Then
        If Sum = 1 Then Sum = 2 : Exit Do
        Item = Replace(Itm, "Path = ", "") : Sum = 1
      ElseIf Itm = "Encrypted = +" And Passw <> 1 Then Exit Sub
      End If
    Loop Until Exe.StdOut.AtEndOfStream
    If Sum = 0 And Ext = "zip" And Len(Arch) < 260 Then
      Dim Items : Set Items = ShA.NameSpace(Arch).Items
      Sum = Items.Count : If Sum Then Item = Items.Item(0)
    End If
    If Sum > 0 Or FSO.GetFile(LPath(Arch)).Size Then
      Dim P, Fd, NF : P = FSO.GetParentFolderName(Arch) : Fd = P & "\" & BN
      If IsObject(Prn) Then Item = Prn.ToUnicode(Item,65001) Else UTF8 Item
      If Sum = 1 And (One = "1" Or BN = Item) Then NF = P Else NF = Fd
      WSS.Run """" & Z7 & """ x """ & Arch & """ -o""" & NF &_
              """ " & Mode & " -y -p" & Pass, 0, True : T = T + 1
      F1 = NF & "\" & Item : LPath(F1) : LPath(Fd) : LPath(Arch)
      If FSO.FileExists(F1) Then
          If Del = 1 And Sum = 1 Then FSO.DeleteFile Arch, 1
      ElseIf FSO.FolderExists(F1) Then
        If FSO.GetFolder(F1).Size Then
          If Del = 1 And Sum = 1 Then FSO.DeleteFile Arch, 1
        ElseIf Sum = 1 Then FSO.DeleteFolder F1, 1 End If
      ElseIf FSO.FolderExists(Fd) Then
        If FSO.GetFolder(Fd).Size Then
          If Del = 1 Then FSO.DeleteFile Arch, 1
        Else FSO.DeleteFolder Fd, 1
        End If : F1 = Fd
      End If
    End If
  End If
End Sub

Sub GetPass(Arc, Text)
  If Len(WSS.Exec("""" & Z7 & """ t """ & Arc & """ -y -p" & Pass).StdErr.Read(1)) Then
    PWTrue = 0 : Pass = InputBox(vbCr & "Архив:  """ & Arc & """" & vbCr & vbCr &_
    Text & vbCr & vbCr & "Введите пароль:", Space(30) & "Распаковка архивов", Pass)
    If Len(Pass) Then Text = Space(40) & "Пароль неверен!" : GetPass Arc, Text
  Else PWTrue = 1 End If
End Sub

Sub UTF8(Nm): Dim F
  While Len(Nm) > 0
    If Asc(Left(Nm,1)) >= 128 Then
      If Asc(Left(Nm,1)) < 224 Then F = F & ChrW(S(Nm,2,64) + S(Nm,1,32)*64):_
        Nm = Right(Nm, Len(Nm)-2) Else F = F & ChrW(S(Nm,3,64) + (S(Nm,2,32)+_
        S(Nm, 1, 16)*64)*64) : Nm = Right(Nm, Len(Nm) - 3)
    Else F = F & Left(Nm, 1) : Nm = Right(Nm, Len(Nm) - 1) End If
  Wend : Nm = F
End Sub : Function S(Name, b, m) S = Asc(Mid(Name, b, 1)) Mod m End Function

Sub ForFolder(Fold, T, F1, Cnt)
  Dim N : Set Fold = FSO.GetFolder(LPath(Fold))
  For Each N In Fold.SubFolders : ForFolder N.Path, Ch, It, Cnt : Next
  For Each N In Fold.Files      : ForFile   N.Path, Ch, It, Cnt : Next
End Sub

Function LPath(Obj)
  LPath = Obj : If Len(Obj) > 259 And Left(Obj, 1) <> "\" Then LPath = "\\?\" & Obj
End Function

Что важно отметить?
Скрипт очень удобен, т. к. позволяет после распаковки автоматически переходить к нужному файлу или файлу в папке, если был распакован один архив.

Во время распаковки можно заниматься своими делами (в т.ч. в других окнах), и как будет всё готово, результат отобразится в панели ТС.

Для этого обязательно третьим параметром нужно указать 1 в качестве флага.

Если указать в качестве параметров %WL "" 1 s и поставить курсор на проверяемый архив, то в случае существования уже распакованного некогда элемента тут же произойдёт переход к нему без предварительной распаковки.

Это также удобно, когда используется последний параметр удаления архива и вы не знаете, что именно распаковано и как это искать самостоятельно.

Скрипт работает с длинными (260+) путями к архивам и каталогам их размещения.

Flasher
12.11.2014