[Iska]

jbk, пробуйте:

Скрытый текст

Код:

Option Explicit

Dim objFSO

Dim strDestFolder
Dim strUserNameDestFolder
Dim strSourceFolder
Dim strFullDestFolder

Dim objFolder
Dim objFile


strDestFolder = "\\server\Profiles$"

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(strDestFolder) Then
	strUserNameDestFolder = objFSO.BuildPath(strDestFolder, WScript.CreateObject("WScript.Network").UserName)
	
	If Not objFSO.FolderExists(strUserNameDestFolder) Then
		objFSO.CreateFolder strUserNameDestFolder
	End If
	
	
	strSourceFolder = WScript.CreateObject("WScript.Shell").SpecialFolders("MyDocuments")
	strFullDestFolder = objFSO.BuildPath(strUserNameDestFolder, objFSO.GetFileName(strSourceFolder))
	
	If Not objFSO.FolderExists(strFullDestFolder) Then
		objFSO.CreateFolder strFullDestFolder
	End If
	
	With objFSO.GetFolder(strSourceFolder)
		.Copy strFullDestFolder, True
	End With
	
	
	strSourceFolder = WScript.CreateObject("WScript.Shell").SpecialFolders("Desktop")
	strFullDestFolder = objFSO.BuildPath(strUserNameDestFolder, objFSO.GetFileName(strSourceFolder))
	
	If Not objFSO.FolderExists(strFullDestFolder) Then
		objFSO.CreateFolder strFullDestFolder
	End If
	
	With objFSO.GetFolder(strSourceFolder)
		.Copy strFullDestFolder, True
		
		For Each objFolder In .SubFolders
			'WScript.Echo "[" & objFolder.Path & "]"
			.Attributes = 0
			.Delete True
		Next
		
		For Each objFile In .Files
			Select Case LCase(objFSO.GetExtensionName(objFile.Name))
				Case "lnk", "url"
					' Nothing to do
				Case Else
					With objFile
						'WScript.Echo objFile.Path
						.Attributes = 0
						.Delete True
					End With
			End Select
		Next
	End With
Else
	WScript.Echo "Can't find destination folder [" & strDestFolder & "]."
	WScript.Quit 1
End If

Set objFSO = Nothing

WScript.Quit 0