Total Commander

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

regsvr32 /s msado15.dll

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

'•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
' Распаковка выбранных архивов и/или архивов в структуре выбранных каталогов
' в одноимённые папки рядом с архивами (при наличии в них более одного элемента)
' c автоматическим переходом в случае распаковки одного архива

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

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

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

Option Explicit : Dim Z7
'••••••••• Путь к утилите 7z.exe •••••••••
Z7 = "%COMMANDER_PATH%\Utils\7-Zip\7z.exe"
'•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••• Автор: Flasher © •••
Dim A, C, Filt, One, Mode, Del, List, WSS, FSO, XML, ShA, Reg, TF, F, Ch, Cn, It
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)
List = A(0) : Set WSS = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set XML = CreateObject("Msxml2.DOMDocument")
Set ShA = CreateObject("Shell.Application")
Set Reg = New Regexp
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?)$"
TF = FSO.GetSpecialFolder(2) & "\" & FSO.GetTempName
With FSO.OpenTextFile(List,,,-1)
  Do : F = Trim(.ReadLine)
    If F <> "" Then If FSO.FileExists("\\?\" & F) Then _
    ForFile F, Ch, It, Cn Else ForFolder F, Ch, It, Cn
  Loop Until .AtEndOfStream : .Close
End With
If Ch > 1 Then WSS.Popup "Распаковка завершена!", 1.4 , " Результат", 64
If Ch = 1 Then
  If Cn > 1 And FSO.FolderExists(It) Then It = FSO.GetParentFolderName(It)
  WSS.Exec "%COMMANDER_EXE% /A /S /O /L=""" & Replace(It, "\\?\", "") & """"
End If : If FSO.FileExists(List) Then FSO.DeleteFile List
If FSO.FileExists(TF) Then FSO.DeleteFile TF

Sub ForFile(Arch, T, F1, Sum)
  Dim Ext, BN, Ex, Arr, 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
    WSS.Run "%comspec% /c chcp 65001&&echo off>" & TF & "&echo ^<?xml version=""" &_
            "1.0"" encoding=""utf-8""?^>^<a^>>>" & TF & "&&""" & Z7 & """ l -slt" &_
             " """ & Arch & """ -sccUTF-8>>" & TF & "&&echo ^</a^>>>" & TF, 0, True
    XML.Load TF : Arr = Split(XML.Text, "----------" & vbLf)(1)
    Arr = Filter(Split(Arr, vbLf), "Path = ") : XML.Abort
    Sum = Ubound(Arr) + 1 : If Sum > 0 Then Item = Split(Arr(0), " = ")(1)
    If Sum < 1 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 Sum = 1 And (One = "1" Or BN = Item) Then NF = P Else NF = Fd
      F1 = NF & "\" & Item
      WSS.Run """" & Z7 & """ x """ & Arch & """ -o""" &_
              NF & """ " & Mode & " -y -p", 0, True : T = T + 1
      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
        Else 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 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

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

Line:56
Char:19
Error: Subscript out of range [number:1]
code: 800A0009