'====================================================================
' AJPapps - Clear recycle bins
' Линда Кайе 2010. Посвящается Ариэль
' 
' Этот скрипт разом отчищает корзинки всех пользователей, 
' расположенные на всех локальных жёстких дисках. Это полезно тем, 
' что отчищаются корзинки для каждого пользователя без необходимости 
' входа в систему от лица каждого из них. Более того, на внешних 
' жёстких дисках часто появляются корзинки пользователей, 
' зарегистрированных в других системах. Такие корзинки можно удалить 
' только вручную. Данный скрипт автоматизирует данный процесс, 
' упрощая ежедневную задачу.
' 
' • 31.08.2009
'   Первая версия ^^
' 
' • 5.07.2010
'   [+] Переписала способ удаления папок. Вместо встроенных средств 
'       используется внешняя оболочка и команда RMDIR. А всё сделано 
'       для того, чтобы если в корзинке окажется ссылка на папку, 
'       скрипт не вынес файлы в этой папке - он просто разорвёт 
'       ссылку. Могут возникнуть лёгкие тормоза. Также не тестировала 
'       пока в Windows 9x.
'  
'====================================================================
' Маленький копирайт
' 
' 1. Программа и исходный код распространяются бесплатно.
' 2. Вы имеете право распространять их на тех же условиях.
' 3. Вы не имеете права использовать имя автора после модификации 
'    исходного кода.
' 4. При этом желательно указывать ссылку на автора оригинальной 
'    версии исходного кода.
' 5. Вы не имеете права на платное распространение исходного кода, 
'    а также программных модулей, содержащих данный исходнй код.
' 6. Программа и исходный код распространяются как есть. Автор не 
'    несёт ответственности за любые трагедии или несчастные случаи, 
'    вызванные использованием программы и исходного кода.
' 7. Для любого пункта данного соглашения может быть сделано 
'    исключение с разрешения автора программы.
' 8. По любым вопросам, связанным с данной программой, обращайтесь 
'    по адресу lindaoneesama@gmail.com
' 
' Загружено с http://purl.oclc.org/Linda_Kaioh/Homepage/
'====================================================================
Option Explicit

Const AppTitle = "AJPapps - Clear recycle bins"

Const FILE_ATTRIBUTE_REPARSE_POINT = 1024
Const SW_SHOWDEFAULT = 10
Const SW_HIDE = 0

Dim FSO
Dim Drive

If MsgBox("Вы действительно хотите отчистить " & _
          "корзинки для всех пользователей?", _
          vbQuestion + vbOkCancel, AppTitle) = vbCancel Then
  WScript.Quit
End If

Set FSO = CreateObject("Scripting.FileSystemObject")

For Each Drive In FSO.Drives
  If Drive.DriveType = 2 Then ' Only fixed...
    Select Case UCase(Drive.FileSystem)
      Case "NTFS"
        DelTree FSO.BuildPath(Drive.RootFolder, "RECYCLER")
      Case "FAT32", "FAT16", "FAT12", "FAT"
        DelTree FSO.BuildPath(Drive.RootFolder, "RECYCLED")
      Case Else
        MsgBox "Файловая система (" & Drive.FileSystem & _
               ") на диске " & Drive.DriveLetter & _
               ": не поддерживается.", vbExclamation, AppTitle
    End Select
  End If
Next

MsgBox "Готово ^_^", vbInformation, AppTitle

'====================================================================
Public Sub DelTree(ByVal Path)
  Dim Folder
  Dim Files
  Dim SubFolders
  Dim File
  Dim SubFolder
  
  On Error Resume Next
  
  Set Folder = FSO.GetFolder(Path)
  If Err Then Exit Sub ' Удалять нечего...
  
  Set Files = Folder.Files
  Set SubFolders = Folder.SubFolders
  
  ' Сначала ковыряем подкаталоги...
  For Each SubFolder In SubFolders
    ' Проверяем, не является ли это символической ссылкой. 
    ' Если нет - удаляем всё в подкаталоге (рекурсивно)...
    If (SubFolder.Attributes And FILE_ATTRIBUTE_REPARSE_POINT) = 0 Then
      DelTree FSO.BuildPath(Path, SubFolder.Name)
    Else
      If Not CallShellRmDir(FSO.BuildPath(Path, SubFolder.Name)) Then
        MsgBox FSO.BuildPath(Path, SubFolder.Name) & vbCrLf & vbCrLf & _
               "Не удаётся разорвать символическую ссылку.", _
               vbCritical, AppTitle
      End If
    End If
  Next
  
  ' Удаляем все файлы в папке. Не удаляем пачкой зачем чтобы было 
  ' ясно, какой файл не удаляется...
  For Each File In Files
    Err.Clear
    FSO.DeleteFile FSO.BuildPath(Path, File.Name), True
    If Err Then MsgBox "Не удаётся удалить файл """ & _
                       FSO.BuildPath(Path, File.Name) & """.", _
                       vbCritical, AppTitle
  Next
  
  ' А теперь удаляем текущий каталог...
  'Err.Clear
  'FSO.DeleteFolder Path, True
  'If Err Then ...
  
  ' Ну его нафиг, будем юзать эту функцию, ибо даже при том, что мы 
  ' разрываем все ссылки, какая-нибудь может не разорваться, и тогда 
  ' эта функция вынесет то, что нельзя удалять и не находится 
  ' в корзинке.
  If Not CallShellRmDir(Path) Then
    MsgBox Path & vbCrLf & vbCrLf & _
           "Не удаётся удалить папку.", _
           vbCritical, AppTitle
  End If
End Sub

'====================================================================
' Эта функция стартует COMMAND.COM или CMD.EXE и вызывает RMDIR, 
' которая не выносит всё дерево, а в случае символической ссылки - 
' разрывает её. Ибо, если в корзине окажется ссылка, то будет 
' плохо =_=
' 
' Жирный минус - мы не знаем, чем закончится вызов: удачей или нет...
' 
' О! Run() возвращает код завершения процесса. А RMDIR возвращает не 
' ноль при неудаче! Оно передаётся комспеку. Тоесть ошибки будем 
' отслеживать через код завершения процесса. Пока протестировала 
' только в NT...
'====================================================================
Private Function CallShellRmDir(ByVal Path)
  Dim SH
  Dim Cmd
  Dim RC
  
  On Error Resume Next
  
  Set SH = WScript.CreateObject("WSCript.Shell")
  Cmd = "%COMSPEC% /C RMDIR """ & Path & """"
  
  RC = SH.Run(Cmd, SW_HIDE, True)
  If Err.Number <> 0 Then
    CallShellRmDir = False
  Else
    CallShellRmDir = CBool(RC = 0)
  End If
End Function