Общая папка для обмена документами в офисе (автоматизация очистки)

Практически всегда, когда несколько компьютеров соединяют в сеть, на одном или нескольких из них появляется папка открытая на запись, для удобства обмена документами между собой. На этом этапе проблем обычно не возникает. Но если такая папка появляется на сервере, куда имеют доступ много сотрудников, то рано или поздно появляется проблема файлопомойки, когда сотрудники не утруждают себя чисткой оставленных там файлов. В этом случае иногда этим занимается системный администратор. Рано или поздно у него возникает желание вбить в голову всех сотрудников, что это папка только для обмена что не стоит там ничего сохранять, но гораздо проще, красивей и эффективней сделать скрипт, который будет предотвращать разрастание файлопомойки.

Что делает скрипт:

• Удаляет все файлы в папке, кроме заданных исключений.
• Складывает все удаленное в отдельную папку (назовем ее «архив»), озаглавленную датой, когда произведено удаление. Так чтоб потом можно было понять что там было удалено в этот день.
• Чистит архив, оставляя там заданное количество папок.

Конечно этот скрипт нужно еще и ежедневно запускать, но тут применяем хотя бы стандартный планировщик задач.

Сам скрипт на VB (сохраняем его например в файл «obmen.vbs»):

'===============чистка папки обмена =============
'файлы и папки переносятся в скрытую папку deleted
'============================================
pObmen = "d:\OBMEN" 'устанавливаем местонахождение папки обмена
pBackup = "D:\BACKUP\deleted\" + fixDate(Date, "yyyy-mm-dd") 'в эту папку будет выполнено перемещение
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set oObmen = fso.GetFolder(pObmen)
'создаем папку, куда будем перемещать
If (Not fso.FolderExists(pBackup)) then
 Set oBackup = fso.CreateFolder(pBackup)
Else
 Set oBackup = fso.GetFolder(pBackup)
End if
'Перемещаем все папки и файлы из обменника в созданную папку
For Each oFolder In oObmen.Subfolders
 if (oFolder.Name<>"Информация") and (oFolder.Name<>"Порядки и положения") and (oFolder.Name<>"Прайсы") then
 oFolder.Move oBackup.Path & "\"
 End If
Next
For Each oFile In oObmen.Files
 if (oFile.Name<>"desktop.ini") then
 oFile.Move oBackup.Path & "\"
 End If
Next
'удаление устаревших папок (число показывает сколько папок оставить)
For i = 15 to 100
 pBackup = pObmen + "\deleted\" + fixDate(Date-i, "yyyy-mm-dd") 'в эту папку будет выполнено перемещение
 If (fso.FolderExists(pBackup)) then
 fso.DeleteFolder pBackup
 End if 
Next
'===================================================================================================================================
'процедура преобразования формата даты
 ' Use: fixDate(valid date string, format string)
Public Function fixDate(strDate,format)

 d = DatePart("D",strDate)
 m = DatePart("M",strDate)
 y = DatePart("YYYY",strDate)

 if len(d) < 2 then
 d = "0" & d
 end if

 if len(m) < 2 then
 m = "0" & m
 end if
 Select Case Format
 Case "yyyy/mm/dd"
 fixDate = y & "/" & m & "/" & d
 Case "yy/mm/dd"
 fixDate = right(y,2) & "/" & m & "/" & d
 Case "dd/mm/yy"
 fixDate = d & "/" & m & "/" & right(y,2)
 Case "dd/mm/yyyy"
 fixDate = d & "/" & m & "/" & y
 Case "yyyy-mm-dd"
 fixDate = y & "-" & m & "-" & d
 Case "yy-mm-dd"
 fixDate = right(y,2) & "-" & m & "-" & d
 Case "dd-mm-yy"
 fixDate = d & "-" & m & "-" & right(y,2)
 Case "dd-mm-yyyy"
 fixDate = d & "-" & m & "-" & y
 Case "ddmmyyyy"
 fixDate = d & m & y
 Case "ddmmyy"
 fixDate = d & m & right(y,2)
 Case "mmddyy"
 fixDate = m & d & right(y,2)
 Case "mmddyyyy"
 fixDate = m & d & y
 Case "yyyymmdd"
 fixDate = y & m & d
 Case "yymmdd"
 fixDate = right(y,2) & m & d
 Case "yyyy"
 fixDate = y
 Case "Short"
 fixDate = formatdatetime(strDate,vbShortDate)
 Case "Long"
 fixDate = formatdatetime(strDate,vbLongDate)
 Case "dd-Month-yyyy"
 m = MonthName (m,True)
 fixDate = d & "-" & m & "-" & y
 Case "dd-Month-yy"
 m = MonthName (m,True)
 fixDate = d & "-" & m & "-" & right(y,2)
 Case "DayName"
 fixDate = WeekDayName(Weekday(strDate),False)
 Case "DayNameAbbr"
 fixDate = WeekDayName(Weekday(strDate),True)
 Case "SiteDate"
 fixDate = WeekDayName(Weekday(strDate),False) & ", " & DateSuffix(DatePart("D",strDate)) & " of " & MonthName(m,false) & ", " & fixDate(strDate,"yyyy")
 Case "Stamp"
 fixDate = fixdate(Now(),"yyyymmdd") & fixTime(Now(),"Stamp")
 Case Else
 fixDate = d & "/" & m & "/" & y
 End Select

 End Function

 Private Function DateSuffix(num)

 Dim x

 if num < 13 or num > 20 then
 Select Case right(num,1)
 Case "0"
 x = "th"
 Case "1"
 x = "st"
 Case "2"
 x = "nd"
 Case "3"
 x = "rd"
 Case else
 x = "th"
 End Select
 End if

 If num > 12 and num < 21 then
 x = "th"
 End If

 DateSuffix = num & x 

 End Function

 Public Function fixTime(strTime,format)
 h = Hour(strTime)
 m = Minute(strTime)
 s = Second(strTime)

 if s < 10 then 
 s = "0" & s
 end if

 if m < 10 then
 m = "0" & m
 end if

 if h < 10 then 
 h = "0" & h
 end if

 Select Case format
 Case "hh:mm:ss"
 fixTime = h & ":" & m & ":" & s
 Case "hhmmss"
 fixTime = h & m & s
 Case "Stamp"
 fixTime = h & m & s
 Case Else
 fixTime = formatdatetime(strTime,vbShortTime)
 End Select

 End Function