'====================================================================
' AJPapps - Transcend no sleep!
' Линда Кайе 2010-2014. Посвящается Ариэль
' 
' Есть у меня вредный жёсткий диск Transcend, который любит при 
' долгом простое отключать сам себя для экономии электричества. 
' Вроде бы полезно, но вот часто не включается он потом обратно. 
' Что делать? Занять его какой-нибудь работой. Вот этот скрипт и 
' работает в фоновом режиме, каждую минуту читая содержимое папки 
' на диске и записывая его в скрытый файл. При этом между запросами, 
' скрипт ни как не занимает диск, так что его можно будет спокойно 
' отмонтировать.
' 
' Скрипт не останавливается даже если вы отмонтировали диск. Если 
' его выполнение нужно прекратить, придётся использовать диспетчер 
' задач.
' 
' • 17.04.2010
'   Первая версия ^^
' 
' • 2.08.2012
'   [+] Появились параметры командной строки /Serial и /Label для 
'       того чтобы файл не писался куда попало только по букве диска, 
'       а работал с конкретным диском.
' 
' • 3.03.2014
'   [+] Теперь можно задать сразу кучу каталогов для занятия работой 
'       чтобы не запускать кучу скриптов.
'   [+] Был глюк с каталогами, указанными только буквой диска ("C:").
'   [+] Разбила основную функцию на кучу мелких функций.
'   [+] Теперь создаваемый файл удаляется чтобы не смущать 
'       пользователя.
' 
'====================================================================
' Маленький копирайт
' 
' 1. Программа и исходный код распространяются бесплатно.
' 2. Вы имеете право распространять их на тех же условиях.
' 3. Вы не имеете права использовать имя автора после модификации 
'    исходного кода.
' 4. При этом желательно указывать ссылку на автора оригинальной 
'    версии исходного кода.
' 5. Вы не имеете права на платное распространение исходного кода, 
'    а также программных модулей, содержащих данный исходный код.
' 6. Программа и исходный код распространяются как есть. Автор не 
'    несёт ответственности за любые трагедии или несчастные случаи, 
'    вызванные использованием программы и исходного кода.
' 7. Для любого пункта данного соглашения может быть сделано 
'    исключение с разрешения автора программы.
' 8. По любым вопросам, связанным с данной программой, обращайтесь 
'    по адресу lindaoneesama@gmail.com
' 
' Загружено с http://purl.oclc.org/Linda_Kaioh/Homepage/
'====================================================================
Option Explicit

Dim FSO
Dim Paths
Dim SerialNum
Dim DiskLabel

Const AppTitle = "AJPapps - Transcend no sleep!"
Const FILE_NAME = "{E5141BCF-0D1F-49AC-8D69-01948AB9B7AD}"

ParseArguments
DoMainLoop

'====================================================================
Private Sub ParseArguments()
  Dim TMP
  Dim TXT
  
  If WScript.Arguments.Unnamed.Count = 0 Then
    ShowUsage
    WScript.Quit
  End If
  
  ' Получаем каталоги. Обратите внимание, что если пользователь 
  ' указал букву диска, мы дописываем слэш. Это сделано для того 
  ' чтобы файл в таком случае писался в корень, а не абы куда.
  Set Paths = New Collection
  For TMP = 0 To WScript.Arguments.Unnamed.Count - 1
    TXT = WScript.Arguments.Unnamed(TMP)
    
    ' Финт ушами! Вместо этого: If TXT Like "?:" Then 
    If Len(TXT) = 2 Then _
      If Mid(TXT, 2) = ":" Then _
        TXT = TXT & "\"
    
    Paths.Add TXT
  Next
  
  ' И дополнительные параметры...
  SerialNum = UCase(Trim(WScript.Arguments.Named("Serial")))
  DiskLabel = UCase(Trim(WScript.Arguments.Named("Label")))
  
  ' Debug...
  'ShowDebugOut
End Sub

Private Sub ShowUsage()
  MsgBox "Использование:" & vbCrLf & vbCrLf & _
         "TranscendNoSleep.VBS " & _
         "PathToFolder [PathToFolder [PathToFolder ...]] " & _
         "[/Serial:SerialNum] [/Label:DiskLabel]" & vbCrLf & _
         vbCrLf & _
         "PathToFilder - каталог на диске, который требуется " & _
         "занять работой. Не обязательно должен быть " & _
         "корневым." & vbCrLf & _
         vbCrLf & _
         "SerialNum - Серийный номер диска, что-то вроде " & _
         "B16B-00B5." & vbCrLf & _
         vbCrLf & _
         "DiskLabel - метка диска." & vbCrLf & _
         vbCrLf & _
         "Значения SerialNum и DiskLabel задают дополнительные " & _
         "условия для работы этого скрипта. Если один из этих " & _
         "параметров не соответствует диску, на котором " & _
         "располагается целевой каталог, скрипт ничего в " & _
         "него писать не будет. Если параметр опущен, то " & _
         "соответствующее условие не проверяется.", _
         vbInformation, AppTitle
End Sub

Private Sub ShowDebugOut()
  Dim TXT
  Dim TMP
  
  For TMP = 0 To Paths.Count - 1
    TXT = TXT & "Path " & TMP & ": " & Paths(TMP) & vbCrLf
  Next
  
  MsgBox TXT & vbCrLf & _
         "SerialNum: " & SerialNum & vbCrLf & _
         "DiskLabel: " & DiskLabel, vbInformation, AppTitle
  
  WScript.Quit
End Sub

'====================================================================
Private Sub DoMainLoop()
  On Error Resume Next
  
  ' Debug...
  'WScript.Echo "DoMainLoop()"
  
  Set FSO = CreateObject("Scripting.FileSystemObject")
  If Err.Number <> 0 Then
    MsgBox "Не удаётся создать объект Scripting.FileSystemObject.", _
           vbCritical, AppTitle
    WScript.Quit
  End If
  
  Do
    CheckDrives
    
    ' Делаем паузу на одну минуту. Этого времени должно хватить чтобы 
    ' не обращаться к диску слишком часто и заодно не превышать 
    ' таймаут отключения диска.
    WScript.Sleep 60000 ' 1 minute
  Loop
End Sub

Private Sub CheckDrives()
  Dim TMP
  
  On Error Resume Next
  
  ' Debug...
  'WScript.Echo "CheckDrives() ==> Paths.Count = " & Paths.Count
  
  For TMP = 0 To Paths.Count - 1
    CheckDrive Paths(TMP)
  Next
End Sub

Private Sub CheckDrive(ByVal Path)
  Dim Folder
  Dim Drive
  Dim File
  Dim TMP
  Dim TXT
  
  ' Debug...
  'WScript.Echo "CheckDrive() ==> Path = " & Path
  
  On Error Resume Next
  
  Err.Clear
  Set Folder = FSO.GetFolder(Path)
  Set Drive = FSO.GetDrive(Folder.Drive)
  
  ' В новой версии мы не будем останавливаться в случае чего. Будем 
  ' просто игнорить ошибку. Это для того чтобы каждый раз не 
  ' перезапускать скрипт...
  If Err.Number <> 0 Then
    
    'WScript.Echo "CheckDrive() ==> Error " & Err.Number & ": " & Err.Description
    
  Else
    
    ' Сверяемся с условиями...
    If Not IsCorrectDisk(Drive, SerialNum, DiskLabel) Then
      
      ' Debug...
      'WScript.Echo "CheckDrive() ==> Incorrect disk"
      
    Else
      
      ' Debug...
      'WScript.Echo "CheckDrive() ==> Correct disk"
      
      ' Тут мы будем тихо игнорить все ошибки. Нам нужно создать 
      ' дисковую активность, а не какие-то осмысленные структуры 
      ' данных.
      TXT = ""
      For Each TMP In Folder.Files
        TXT = TXT & TMP.Name & vbCrLf
      Next
      
      ' Чтобы можно было что-то в файл записать, мы должны сделать 
      ' его видимым. Ну, вот так вот устроена FSO библиотека...
      Set File = Folder.Files(FILE_NAME)
      File.Attributes = 0 ' Normal
      
      ' Пишем полученный список файлов...
      Set File = Folder.CreateTextFile(FILE_NAME, True, True)
      File.Write TXT
      File.Close
      
      ' Снова скрываем файл чтобы не мешался пользователю.
      'Set File = Folder.Files(FILE_NAME)
      'File.Attributes = 2 ' Hidden
      
      ' Лучше удаляем файл нафиг чтобы не смущал пользователя!
      Set File = Folder.Files(FILE_NAME)
      File.Delete
      
      Set File = Nothing
      Set Folder = Nothing
      
    End If
  End If
End Sub

'====================================================================
' Проверяет, соответствует ли заданный диск заданным серийному номеру 
' и метке.
'====================================================================
Private Function IsCorrectDisk(ByVal Drive, ByVal SerialNum, ByVal DiskLabel)
  IsCorrectDisk = False
  If IsCorrectDiskSerial(Drive, SerialNum) Then
    If IsCorrectDiskLabel(Drive, DiskLabel) Then
      IsCorrectDisk = True
    End If
  End If
End Function

Private Function IsCorrectDiskSerial(ByVal Drive, ByVal SerialNum)
  If SerialNum = "" Then
    IsCorrectDiskSerial = True
  Else
    If FormatSerial(Drive.SerialNumber) = SerialNum Then
      IsCorrectDiskSerial = True
    Else
      IsCorrectDiskSerial = False
    End If
  End If
End Function

Private Function FormatSerial(ByVal Num)
  FormatSerial = Hex(Num)
  FormatSerial = String(8 - Len(FormatSerial), "0") & FormatSerial
  FormatSerial = Left(FormatSerial, 4) & "-" & Mid(FormatSerial, 5)
  
  ' Debug...
  'MsgBox FormatSerial, vbInformation, AppTitle
End Function

Private Function IsCorrectDiskLabel(ByVal Drive, ByVal DiskLabel)
  If DiskLabel = "" Then
    IsCorrectDiskLabel = True
  Else
    If UCase(Drive.VolumeName) = DiskLabel Then
      IsCorrectDiskLabel = True
    Else
      IsCorrectDiskLabel = False
    End If
  End If
End Function

'====================================================================
' Этот класс можно использовать в других скриптах как реализацию 
' коллекции в стиле VB5 - VB6.
'====================================================================
Class Collection
  ' Объект словаря
  Private mDic
  Private mUniqueKey
  
  Private Sub Class_Initialize   ' Setup Initialize event.
    'MsgBox("TestClass started")
    Set mDic = CreateObject("Scripting.Dictionary")
    mUniqueKey = 0
  End Sub
  
  Private Sub Class_Terminate   ' Setup Terminate event.
    'MsgBox("TestClass terminated")
    Set mDic = Nothing
  End Sub
  
  Public Sub Add(ByVal Item)
    mDic.Add CStr(mUniqueKey), Item
    mUniqueKey = mUniqueKey + 1
  End Sub
  
  Public Default Function Item(ByVal Index)
    Dim Key
    Dim Keys
    
    Keys = mDic.Keys
    Key = Keys(Index)
    
    Item = mDic.Item(Key)
  End Function
  
  Public Function ItemObj(ByVal Index)
    Dim Key
    Dim Keys
    
    Keys = mDic.Keys
    Key = Keys(Index)
    
    Set ItemObj = mDic.Item(Key)
  End Function
  
  Public Function Count()
    Count = mDic.Count
  End Function
  
  Public Sub Clear()
    mDic.RemoveAll
  End Sub
  
  Public Sub Remove(ByVal Index)
    Dim Key
    Dim Keys
    
    Keys = mDic.Keys
    Key = Keys(Index)
    
    mDic.Remove Key
  End Sub
  
  ' Отладочная функция
  Public Sub DebugOut()
    Dim TMP
    
    WScript.Echo "Collection contents..."
    
    For TMP = 0 To Me.Count - 1
      WScript.Echo "  " & Me.Item(TMP)
    Next
    
    WScript.Echo "Listed " & TMP & " items."
    WScript.Echo ""
  End Sub
End Class

' Привет демонам! ^_^