dmitriypopov86
Касаемо первый задачи: структура должна сохраняться, или всё кидать в одну папку? Если да, то букву диска не брать?
Это одноразовая задача? Насколько тут принципиален vbs?
А то можно было бы воспользоваться инструментарием Total Commander, например.
Ладно, я ждать уже не буду. Потом отпишитесь. Пока так (tempout.txt в UTF-16):
'================================================================================
' Назначение: копирование файловой структуры по списку базовых имён
' Параметры: "<путь к исходной папке>" "<путь к целевой папке>" "<путь к списку>"
'================================================================================
Option Explicit
Dim Title, IDir, ODir, List, LenID, Shell, FSO, Filt, OutDisk, Chek
Title = " Копирование структуры файлов по списку имён "
With WScript.Arguments
If .Count <> 3 Then MsgBox "Укажите 3 параметра!", 4144, Title : WScript.Quit
IDir = .Item(0) : ODir = .Item(1) : List = .Item(2)
End With : LenID = Len(IDir) + 1
Set Shell = CreateObject("Shell.Application")
Set FSO = CreateObject("Scripting.FileSystemObject")
Filt = Join(Split(FSO.OpenTextFile(List,,,-1).ReadAll, vbNewLine), ".*;") & ".*"
Set OutDisk = Shell.NameSpace(FSO.GetDriveName(ODir))
FFolder IDir, Chek : If Chek = 1 Then MsgBox "Выполнено!", 4160, Title Else _
MsgBox "Нет файлов с заданными базовыми именами!", 4144, Title
Sub FFolder(Folder, T)
Dim Items, OutDir, Fd
Set Folder = Shell.NameSpace(Folder)
Set Items = Folder.Items
Items.Filter 75968, Filt
If Items.Count Then
OutDir = FSO.BuildPath(ODir, Mid(Folder.Self.Path, LenID))
If Not FSO.FolderExists(OutDir) Then OutDisk.NewFolder(Mid(OutDir, 4))
T = 1 : Shell.NameSpace(OutDir).CopyHere Items, 280
End If
Items.Filter 73888, "*"
For Each Fd In Items : FFolder Fd.Path, T : Next
End Sub
