[OSArev]

ksv_sergo, ответы на такие вопросы в любой справке есть.

Код:

Dim fso, ImputName2, FolderName1 

Set fso = CreateObject("Scripting.FileSystemObject")
FolderName1 = "d:\1\FOX"   'Копируемая папка

ImputName2 = InputBox ("Введите имя для создания папки архива")
Set Fldr = fso.CreateFolder ("d:\2\" & ImputName2) 'тут не хватало слэша
fso.CopyFolder FolderName1, "d:\2\" & ImputName2, true

[ksv_sergo]

OSArev, спасибо за ответ.
Справки я уже перечитал вдоль и поперёк, но всё равно не срабатывает.

Применил ваш скрипт, результат старый В папку копируется только содержимое FOX, а не сама папка полностью.

Set Fldr = fso.CreateFolder ("d:\2\" & ImputName2) 'тут не хватало слэша »

тут наличие слеша не важно, папка создаётся хоть с слешем хоть без него.

[amel27]

Справки я уже перечитал вдоль и поперёк, но всё равно не срабатывает. »

папка назначения = ПУТЬ + новое ИМЯ папки

Код:

Set FSO = CreateObject("Scripting.FileSystemObject")

strFolder1 = "D:\1\FOX"
strFolder2 = InputBox ("Введите имя для создания папки архива")
strFolder2 = "D:\2\" & strFolder2

If Not FSO.FolderExists(strFolder2) Then FSO.CreateFolder(strFolder2)
strFolder2 = strFolder2 &"\"& FSO.GetFileName(strFolder1)
FSO.CopyFolder strFolder1, strFolder2, vbTrue

[Ins_16]

Код:

Set FSO = CreateObject("Scripting.FileSystemObject")

Set Folder = FSO.GetFolder("d:\1\FOX\")'Копируемая папка
ImputName2 = InputBox ("Введите имя для создания папки архива")
Set enddir = FSO.CreateFolder ("D:\times\" & ImputName2)
Set NewFolder = enddir.SubFolders.Add("FOX")'Создаём подпапку
Folder.Copy enddir & "\FOX"'Копируем в подпапку

Попробуйте такой вариант.

[ksv_sergo]

Всем спасибо, оба варианта сработали !