автоматиеская очистка рабочего стола

[sanek-l]

посоветуйте как с помощью сценария входа в систему очищать рабочий стол – чтобы оставался фиксированный набор ярлыков, а все файлы и папки перемещались в папку пользователя. ограничение – под конкретного пользователя, а не всех сразу.
в идеале текст сценария и куда его подставить.

[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! Прошу отписаться по факту проверки...