[deepred]

sanek-l,

Код:

Option Explicit

Dim objFSO, objWshShell, objShell
Dim objFile, objSubFolder, objFolder
Dim objFolderItem, objShellFolder
Dim objWshShortcut, strDesktop, strDstPath
Dim strUserTask, strUserName, strTask

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

  strDesktop      =  objWshShell.SpecialFolders("Desktop")  ' Определяем "Рабочий стол" пользователя
  strDstPath      =  objWshShell.SpecialFolders("MyDocuments")
  strUserName     =  objwshshell.ExpandEnvironmentStrings("%USERNAME%")
  strDstPath      =  strDstPath &"\"&"DeskResource"  ' Определяем целевую папку (в "Моих документах")
  strUserTask     =  "HP Pavilion"   ' Определяем "конкретного пользователя"
 
  If Not strUserTask = strUserName Then

     MsgBox "Процедура не предусмотрена для текущего пользователя"  ' Если пользователь не тот, то... (необязательно)
     WScript.Quit 0
   
  Else
    
       strTask = False
       Call ClearDesktop("str")
       IF strTask Then
          Call Shortcut("str")
       End if

       Set objShell    = Nothing
       Set objWshShell = Nothing
       Set objFSO      = Nothing
     
  End If

Wscript.Echo "Сценарий успешно выполнен!"  ' Необязательно
WScript.Quit 0

' ************************************************************************
  Function ClearDesktop(str)   ' Проверяем все элементы рабочего стола
  
     set objFolder = objFSO.GetFolder(strDesktop)

     For Each objFile In objFolder.Files
                                                          ' Если не ярлык
                                                         ' и не ярлык интернета (можно убрать)
                                                         ' и не файл desktop.ini 

         IF UCase(objFSO.GetExtensionName(objFile)) <> UCase("lnk") And _  
            UCase(objFSO.GetExtensionName(objFile)) <> UCase("url") And _  
            objFSO.GetBaseName(objFile.Name) <> "desktop" Then  
               strTask = True

               If Not objFSO.FolderExists(strDstPath) Then   ' Если целевой папки нет
                  objFSO.CreateFolder strDstPath   ' создаем её
               End If

               objFile.Move strDstPath &"\"   ' перемещаем файлы

         End if
     Next
' -------------------------------------------------------------------------
    For Each objSubFolder In objFolder.SubFolders

    Set objShellFolder = objShell.NameSpace(objSubFolder.Path)

        IF Not Len(objShellFolder.Self) < Len(objSubFolder.Name) Then ' Если папка не ярлык 
              strTask = True

               If Not objFSO.FolderExists(strDstPath) Then
                  objFSO.CreateFolder strDstPath
               End If

               If objSubFolder.Files.Count = 0 Then   ' Если папка пустая
                  objSubFolder.Delete  ' Удаляем 
               Else
                  objSubFolder.Move strDstPath &"\"  ' Если нет - перемещаем
               End If

        End if
     Next
  End function

' *************************************************************************
 Function Shortcut(str)   ' Создаем ярлык для папки с перемещенными файлами (если его нет)    

     If not objFSO.FileExists(strDesktop & "\DeskResource.lnk") Then

        Set objWshShortcut = objWshShell.CreateShortcut(strDesktop & "\DeskResource.lnk")

        objWshShortcut.WorkingDirectory = strDstPath
        objWshShortcut.TargetPath       = strDstPath
        objWshShortcut.Description = "Сохраненные файлы рабочего стола"
        objWshShortcut.IconLocation = "shell32.dll, 260"
        objWshShortcut.Save

     End If

 End function

Испытано на WinVista! Прошу отписаться по факту проверки...