Распаковка и развертывание избыточной вложенности папок

[helb]

Требовалось решение проблемы с распаковкой вслепую (Alt+F9), когда неизвестно, что в корне архива и можно получить или избыточные вложенные директории или кучу файлов скопом, где не нужно, а также развертывание само по себе.
Скрипт в одно нажатие:
1) Файлы отдает 7zip'у на распаковку в папку с именем архива и применяет к образовавшимся папкам второе;
2) Папки развертывает по принципу: если внутри всего один объект, перемещать на уровень вверх и удалять пустую (своего рода Flatten directories)
По окончании, если потребовались действия, выдает информацию о перемещенных объектах и/или конфликтах. Я повесил на F9 и использую с 7zG.exe (отображает прогресс)

unpack-unfold.vbs:

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

'============================================================
' Распаковка и развертывание избыточной вложенности папок (by helb)
' Указанные в списке: архивы — распаковывает в одноимённые папки с развертыванием, папки — развертывает (пустые удаляет)
' Параметры: <listfile> ["<path>"] (если путь не указан, распаковывает в место нахождения архива)
' TC: %WL "%P"
'====================== Путь к 7z/7zG =======================
tool = "B:\Progs\Archivers\7-Zip\7zG.exe"
'============================================================
with WScript.Arguments
	if .Count = 0 then WScript.Quit
	List = .Item(0)
	if .Count > 1 then Path = .Item(1) else Path = ""
end with
if Right(Path, 1) <> "\" and Path <> "" then Path = Path & "\"
set FSO = CreateObject("Scripting.FileSystemObject")
set sh = CreateObject("WScript.Shell")
conflicts = "" : unfolded = 0

for each F in Split(FSO.OpenTextFile(List, 1, false, -1).ReadAll, vbNewLine)
	if objExists(F) > 0 then
		if FSO.FileExists(F) then 'archive(file)
			if Path <> "" then BN = Path else BN = FSO.GetParentFolderName(F) & "\"
			BN = BN & FSO.GetBaseName(F) : NN = BN : n = 0
			do while FSO.FolderExists(NN)
				n = n + 1
				NN = BN & " (" & n & ")"
			loop
			sh.Run tool & " x """ & F & """ -o""" & NN & "\"" -y", 8, true
		else 'folder
			NN = F
			if Right(NN, 1) = "\" then NN = Left(NN, Len(NN)-1)
		end if
		if FSO.FolderExists(NN) then
			cnt = (FSO.GetFolder(NN).Files).Count + (FSO.GetFolder(NN).SubFolders).Count
			if cnt = 1 then
				set fObjs = FSO.GetFolder(NN).Files
				if fObjs.Count = 0 then set fObjs = FSO.GetFolder(NN).SubFolders
				for each fObj in fObjs
					targetPath = fObj.ParentFolder.ParentFolder & "\"
					if fObj.Name = fObj.ParentFolder.Name then
						set parent = FSO.GetFolder(fObj.ParentFolder)
						FSO.CreateFolder(targetPath & "DCF8E1E9-F66B-4C95-A4E7-47B9591DADBA")
						fObj.Move(targetPath & "DCF8E1E9-F66B-4C95-A4E7-47B9591DADBA\")
						parent.Move(targetPath & "DCF8E1E9-F66B-4C95-A4E7-47B9591DADBA_t")
						fObj.Move(targetPath)
						FSO.DeleteFolder targetPath & "DCF8E1E9-F66B-4C95-A4E7-47B9591DADBA", true
						parent.Delete(true)
						unfolded = unfolded + 1
					elseif objExists(targetPath & fObj.Name) > 0 then
						conflicts = conflicts & fObj.Name & vbNewLine
					else
						fObj.Move(targetPath)
						FSO.DeleteFolder NN, true
						unfolded = unfolded + 1
					end if
				next
			elseif cnt = 0 then
				FSO.DeleteFolder NN, true
				unfolded = unfolded + 1
			end if
		end if
	end if
next
if conflicts <> "" or unfolded > 0 then WScript.Echo("Unfolded: " & unfolded & vbNewLine & "Conflicts: " & vbNewLine & conflicts)

'0=not exists, 1=is file, 2=is folder
function objExists(name)
	if FSO.FileExists(name) then 
		objExists = 1
	elseif FSO.FolderExists(name) then
		objExists = 2
	else
		objExists = 0
	end if
end function

[Nick]

Выходит с ошибкой

Строка: 28
Символ 11
Ошибка: Не удается найти указанный файл
...
Источник: (null)


TC 8.51a x64

[Flasher]

Nick
Сперва вопрос - какая задача поставлена?
Я могу предложить (по аналогии с этим)
[cut="вариант оптимальнее:"]

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

'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
' 1) Перемещение в активную панель одиночных элементов из выбранных каталогов
'    с последующим удалением этих каталогов и автопереименованием элементов
'    при существование одноимённых элементов другого размера
' 2) Распаковка выбранных архивов в одноимённые папки активного каталога,
'    при наличии в них одного элемента (каталога или файла) - в активную панель
' 3) Автоматический переход к перемещённому каталогу или файлу
'    в случае обработки одной папки или архива

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

' Примеры: %WL | %WL s 1

' Автор - Flasher ©

'••••••••• Путь к утилите 7z.exe •••••••••
Z7 = "%COMMANDER_PATH%\Utils\7-Zip\7z.exe"
'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••

Set A = WScript.Arguments : C = A.Count : If C = 0 Then WScript.Quit
If C > 1 Then Mode = "-ao" & A(1) : If C > 2 Then Del  = A(2)
List = A(0) : Dim WSH : Set WSH = CreateObject("WScript.Shell")

If InStrRev(WScript.FullName, "WScript.exe") Then
  For Par = 1 To C - 1
    If A(Par) <> "" Then
      Pars = Pars & " " & A(Par)
    ElseIf C - 1 > Par Then Pars = Pars & " """""
    End If 
  Next : WSH.Run "CScript.exe """ & WScript.ScriptFullName & """ " & List & Pars, 0
  WScript.Quit
End If

Set ShA  = CreateObject("Shell.Application")
Set Dict = CreateObject("Scripting.Dictionary")
Set FSO  = CreateObject("Scripting.FileSystemObject")
Exts = "zip,7z,7zip,arj,bz2,bzip2,cab,chm,chw,cpio,cramfs,deb,dmg," &_
"doc,exe,fat,gz,gzip,hfs,hxs,iso,lha,lzma,mbr,msi,ntfs,ppt,rar," &_
"rpm,scap,squashfs,swm,tar,taz,tbz,tbz2,tgz,vhd,wim,xar,xls,xz"
For Each E in Split(Exts, ",") : Dict.Add E, "" : Next
With FSO.OpenTextFile(List,,,-1)
  Do Until .AtEndOfStream
    F = Trim(.ReadLine)
    If F <> "" Then
      If FSO.FolderExists(F) Then
        Set Folder = ShA.NameSpace(F) : Set Items = Folder.Items
        Cn = Items.Count
        If Cn = 1 Then
          Set Name = Items.Item(0)
          F1 = FSO.GetParentFolderName(F) & "\" & Name
          If Not FSO.FileExists(F1) Or _
          (FSO.FileExists(F1) And Name.Size <> FSO.GetFile(F1).Size) Then
            ShA.NameSpace(Folder.ParentFolder).CopyHere Items, 28 : T = T + 1
          End If
        End If : If Cn < 2 Then FSO.GetFolder(F).Delete
      ElseIf Dict.Exists(LCase(FSO.GetExtensionName(F))) Then
        Set Exe = WSH.Exec("%comspec% /c chcp 1251 | """ & Z7 & """ l" &_
        " -slt """ & F & """ -sccUTF-8| find ""Path = ""| find /v ""\""")
        Item = Replace(Exe.StdOut.ReadLine, "Path = ", "")
        Sum = 0 : If Item <> "" Then Sum = 1
        If Exe.StdOut.ReadLine <> "" Then Sum  = 2
        If Sum > 0 Then
          P = FSO.GetParentFolderName(F) : Fd = P & "\" & FSO.GetBaseName(F)
          If Sum = 1 Then NF = P Else NF = Fd
          WSH.Run """" & Z7 & """ x """ & Arch & """ -o""" &_
                  NF & """ " & Mode & " -y -p", 0, True : T = T + 1
          With CreateObject("ADODB.Stream")
            .Type = 2 : .Open : .Charset = "windows-1251" : .WriteText Item
            .Position = 0  : .Charset = "UTF-8" : Item = .ReadText : .Close
          End With : F1 = NF & "\" & Item : If Del = 1 Then FSO.DeleteFile F, 1
          If Not FSO.FileExists(F1) And Not FSO.FolderExists(F1) And _
          FSO.FolderExists(Fd) Then F1 = Fd
        End If
      End If
    End if
  Loop
End With
If T > 1 Then WSH.Popup "Распаковка завершена!", 1.4 , " Результат", 64
If T = 1 Then WSH.Exec """%COMMANDER_EXE%"" /S /O /L=""" & F1 & "\:"""

[/cut]

[Nick]

Nick
Сперва вопрос - какая задача поставлена?

Распаковать все выделенные архивы через WinRAR в активную панель.
Каждый архив должен распаковываться в отдельную папку (с именами архивов).

Опционально:
Если в начальной папке, подпапка и родительская папка – одинаковые, то оставить одну. (Например: «Новая папка\Новая папка\file.txt», то оставить только одну («Новая папка\file.txt)).
ИЛИ
Опционально:
Если архив уже содержит внутри такое же название папки как и самого архива, то применить распаковку в текущую папку, если нет – распаковать в папку с именем архива. Т.е. какая-то проверка еще до разархивирования.
(Но этот вариант, наверно сложнее и возможно дольше будет выполняться.)

[Flasher]

Nick
Так и думал, что только архивов касается. Тогда в тему по приведённой ссылке и переносимся.