Помогите допилить скрипт*(create subfolders )

[datosha]

добрый вечер , помогите допилить
не могу создать subfolders
задача
1 создать subfolders (desktop, favorits , My documents ) в переменной (strDirectory) .
2 переписать Desktop , favorits , My Documents в новую папку (strDirectory)




Option Explicit
Dim objFSO, objFolder, objShell, strDirectory, filesys, WshShell, WshEnv, strusername, fso
strDirectory = InputBox("Enter Folder Name:", "Creating...")
'For cancel or blank
If strDirectory=Empty Then
WScript.Quit
End If

Set objFSO = CreateObject("Scripting.FileSystemObject")
'searche dublicate folders.
'Add open folders
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
WScript.Echo "Folder ''"& strDirectory &"'' found "
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
'WScript.Echo "NEW FOLDER CREATED ''"& strDirectory &"''."
End If

Set WshShell = CreateObject("WScript.Shell")
Set WshEnv = WshShell.Environment("SYSTEM")
StrUsername = wshShell.ExpandEnvironmentStrings("%username%")
msgbox strUsername

Set filesys=CreateObject("Scripting.FileSystemObject")
If filesys.FolderExists(strDirectory) Then
filesys.CopyFolder "C:\Documents and settings\" & StrUsername & "\Desktop", (strDirectory)
End If

Set filesys=CreateObject("Scripting.FileSystemObject")
If filesys.FolderExists(strDirectory) Then
filesys.CopyFolder "C:\Documents and settings\" & StrUsername & "\application data\microsoft\signature", (strDirectory)
End If

If err.number = vbEmpty then
Set objShell = CreateObject("WScript.Shell")
objShell.run ("Explorer" &" " & strDirectory & "\" )
Else
WScript.echo "Usp..errore vbscript: " & err.number
End If

WScript.Quit

[Iska]

datosha, что именно у Вас не получается, и что означает «переписать» — переместить или скопировать?

[datosha]

Нужно чтобы создавалась по папки Desktop , My Documents , signature
В Новой папке и туда копирывались данные слокального профиля

пока толко создает новую папку и копирует Desktop .

Set filesys=CreateObject("Scripting.FileSystemObject")
If filesys.FolderExists(strDirectory) Then
filesys.CopyFolder "C:\Documents and settings\" & StrUsername & "\application data\microsoft\signature", (strDirectory) <-- как в таком случае создать и записать имя папки ?
End If

[Iska]

Так:
desktop, favorits , My documents »
или:
Desktop , My Documents , signature »
?

[datosha]

In InputBox "create new folder "
then copy to this folder desktop , favorits , my documents , ( folders ,subfolders , from local user )

[Iska]

Option Explicit

Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_USENEWUI = &H50

Const ssfDRIVES = &H11


Dim objShell
Dim objFSO

Dim objDestFolder
Dim strDestFolder

Dim strPath

Dim objSourceFolder
Dim strSourceFolder


Set objShell = WScript.CreateObject("Shell.Application")
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

Set objDestFolder = objShell.BrowseForFolder(0, "Select destination folder", BIF_RETURNONLYFSDIRS + BIF_USENEWUI, ssfDRIVES)

If Not objDestFolder Is Nothing Then
With objFSO
strDestFolder = objDestFolder.Self.Path

If .FolderExists(strDestFolder) Then
For Each strPath In Array("shell:Desktop", "shell:Favorites", "shell:Personal")
Set objSourceFolder = objShell.NameSpace(strPath)

If Not objSourceFolder Is Nothing Then
strSourceFolder = objSourceFolder.Self.Path

.CopyFolder strSourceFolder, .BuildPath(strDestFolder, .GetBaseName(strSourceFolder)), True

Set objSourceFolder = Nothing
Else
WScript.Echo "Can't determine [" & strPath & "] source folder"
End If
Next
Else
WScript.Echo "Can't determine [" & strDestFolder & "] destination folder"
End If
End With
End If

Set objFSO = Nothing
Set objShell = Nothing

WScript.Quit
'=============================================================================

[datosha]

wow , круто ,,,,, огромное спасибо .....