'==================================================================== ' AJPapps - Network drive fixer ' Линда Кайе 2009-2017. Посвящается Ариэль ' ' Этот скрипт поможет справиться с тормозами Проводника при наличии ' сетевых дисков. Если компьютер, к которому подключен сетевой диск, ' окажется недоступен, могут наблюдаться тормоза при открытии папок ' в Проводнике или создании папок в окне сохранения файла. Этот ' скрипт проверяет доступность компьютера и подключает, либо ' отключает диск. То есть вы будете видеть диск только тогда, когда ' он действительно доступен. ' ' Вот пример использования скрипта. Допустим, у нас есть следующие ' сетевые диски: ' ' Q: ==> \\ARIEL\C$ ' R: ==> \\ILISE\Tools\Hack ' ' Скрипт будет запускаться так: ' ' NetworkDriveFixer.VBS Q \\ARIEL\C$ R \\ILISE\Tools\Hack ' ' Путь, указанный после буквы будет использоваться для проверки ' доступности компьютера. Кроме того, он же будет использоваться для ' подключения диска. ' ' Скрипт делает одну проверку и завершается. Поэтому следует его ' запускать посредством планировщика через определённые промежутки ' времени (скажем, раз в минуту). Кроме того, можно раскомментировать ' строки помеченные как '[REMOVE]' - в этом случае скрипт будет ' бесконечно крутиться в цикле и проверять соединение раз в минуту. ' ' • 5.11.2009 ' Первая версия ^^ ' ' • 11.11.2009 ' [-] Ошибка в функции() - диск вообще не монтировался. ' ' • 3.03.2017 ' [+] Из имени файла убраны пробелы. ' [+] Поправлен вывод Usage. ' '==================================================================== ' Маленький копирайт ' ' 1. Программа и исходный код распространяются бесплатно. ' 2. Вы имеете право распространять их на тех же условиях. ' 3. Вы не имеете права использовать имя автора после модификации ' исходного кода. ' 4. При этом желательно указывать ссылку на автора оригинальной ' версии исходного кода. ' 5. Вы не имеете права на платное распространение исходного кода, ' а также программных модулей, содержащих данный исходный код. ' 6. Программа и исходный код распространяются как есть. Автор не ' несёт ответственности за любые трагедии или несчастные случаи, ' вызванные использованием программы и исходного кода. ' 7. Для любого пункта данного соглашения может быть сделано ' исключение с разрешения автора программы. ' 8. По любым вопросам, связанным с данной программой, обращайтесь ' по адресу lindaoneesama@gmail.com ' ' Загружено с http://purl.oclc.org/Linda_Kaioh/Homepage/ '==================================================================== Option Explicit Const AppTitle = "AJPapps - Network drive fixer" Dim FSO Dim File Dim TMP CheckParams On Error Resume Next Set FSO = CreateObject("Scripting.FileSystemObject") If Err Then MsgBox "Не удаётся создать Scripting.FileSystemObject.", vbCritical WScript.Quit End If '[REMOVE]'Do For TMP = 0 To WScript.Arguments.Count - 1 Step 2 PingAndMount WScript.Arguments(TMP), _ WScript.Arguments(TMP + 1) Next '[REMOVE]' WScript.Sleep 60000 '[REMOVE]'Loop '==================================================================== Private Sub CheckParams() Dim TMP If WScript.Arguments.Count = 0 Then ShowUsage WScript.Quit End If If WScript.Arguments.Count \ 2 <> WScript.Arguments.Count / 2 Then ShowUsage WScript.Quit End If For TMP = 0 To WScript.Arguments.Count - 1 Step 2 If Len(WScript.Arguments(TMP)) <> 1 Then ShowUsage WScript.Quit End If Next End Sub Private Sub ShowUsage() MsgBox "Использование:" & vbCrLf & vbCrLf & _ WScript.ScriptName & " DriveLetter NetworkPath [...]" & vbCrLf & vbCrLf & _ "DriveLetter - буква сетевого диска." & vbCrLf & _ "NetworkPath - путь к шаре, на которую назначен диск." & vbCrLf & vbCrLf & _ "Можно указать несколько пар параметров.", _ vbInformation, AppTitle End Sub '==================================================================== Private Sub PingAndMount(ByVal DriveLetter, _ ByVal PingPath) If IsMachineOffline(PingPath) Then If IsDriveExist(DriveLetter) Then DismountDrive DriveLetter End If Else If Not IsDriveExist(DriveLetter) Then MountDrive DriveLetter, PingPath End If End If End Sub '==================================================================== Private Function IsDriveExist(ByVal DriveLetter) Dim Drive For Each Drive In FSO.Drives If UCase(DriveLetter) = UCase(Drive.DriveLetter) Then IsDriveExist = True Exit Function End If Next IsDriveExist = False End Function Private Function IsMachineOffline(ByVal PingPath) IsMachineOffline = Not FSO.FolderExists(PingPath) End Function '==================================================================== Private Sub MountDrive(ByVal DriveLetter, _ ByVal NetworkPath) Dim WshNetwork On Error Resume Next ' Удаляем обратный слэш... NetworkPath = Trim(NetworkPath) If Right(NetworkPath, 1) = "\" Then NetworkPath = Left(NetworkPath, Len(NetworkPath) - 1) End If ' Обновляем профиль пользователя на всякий пожарный... Set WshNetwork = WScript.CreateObject("WScript.Network") WshNetwork.MapNetworkDrive DriveLetter & ":", NetworkPath, True 'If Err Then MsgBox Err.Description End Sub Private Sub DismountDrive(ByVal DriveLetter) Dim WshNetwork On Error Resume Next ' Тут важно тоже обновить профиль пользователя, иначе диск будет ' виден в Моём компьютере, а скрипт будет считать, что всё ' отключено. Более того, он просто не сможет потом снова его ' подключить - диск занят, и всё тут... Set WshNetwork = WScript.CreateObject("WScript.Network") WshNetwork.RemoveNetworkDrive DriveLetter & ":", True, True 'If Err Then MsgBox Err.Description End Sub