RuStn
Junior Member | Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
Внесу свою лепту:
Замена путей в ярлыках, старый путь на новый, с возможностью поиска по всему диску
Код: '********************************************************************
'*http://www.tek-tips.com/viewthread.cfm?qid=1207618&page=1
'*Скрипт по замене свойств ярлыков, заменяет пути в ярлыках
'*Запускать /localFolderToSearch:"c:\xyz\pqr" /targetToReplace:"\\OldServer\" /replacementTarget:"\\NewServer\"
'*
'********************************************************************
Dim sarg1,sarg2,sarg3,sarg4,objFSO,objDrive,oFso,oFolder,oFiles,oFile,oLnk
Set oShell = CreateObject("WScript.Shell")
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
'********************************************************************
'*Определим аргументы запущенные в коммандной строке
'********************************************************************
With wscript.arguments.Named
sarg1=LCase(.item("localFolderToSearch"))
sarg2=LCase(.item("targetToReplace"))
sarg3=LCase(.item("replacementTarget"))
End With
'********************************************************************
'*Проверим эти аргументы на условия:
'*Desktop, AllUsersDesktop, MyDocuments, Startup
'*Но можно указать поиск на всех жёстких дисках
'*аргумент /localFolderToSearch:"AllDrivers" заставит пробежать по всем дискам
'*и проверить все папки и подпапки
'********************************************************************
If sarg1="" Or sarg2="" or sarg3="" Then
msgbox "Запускайте с такими параметрами:" & vbCr & vbCr &_
"/localFolderToSearch:""c:\xyz\pqr"" /targetToReplace:""\\OldServer\"" /replacementTarget:""\\NewServer\""" & vbCr & vbCr &_
"Путь где искать" & vbTab & "Что менять в пути" & vbTab & vbTab & "Что должно стать в пути" & vbCr &_
"c:\xyz\pqr" & vbTab & "\\OldServer\" & vbTab & vbTab & "\\NewServer\" & vbCr & vbCr &_
"Можно указать Desktop, AllUsersDesktop, MyDocuments, Startup" & vbCr & vbCr &_
"А можно поискать на всех дисках: AllDrivers", vbInformation, "Внимание"
ElseIf sarg1="desktop" Then
sarg4=oShell.SpecialFolders("Desktop")
ReplaceShortcut sarg4,sarg2,sarg3
ElseIf sarg1="allusersdesktop" Then
sarg4=oShell.SpecialFolders("AllUsersDesktop")
ReplaceShortcut sarg4,sarg2,sarg3
ElseIf sarg1="mydocuments" Then
sarg4=oShell.SpecialFolders("MyDocuments")
ReplaceShortcut sarg4,sarg2,sarg3
ElseIf sarg1="startup" Then
sarg4=oShell.SpecialFolders("Startup")
ReplaceShortcut sarg4,sarg2,sarg3
ElseIf sarg1="alldrivers" Then
FindDrivers
End If
'*Ну и обязательно выйдем из скрипта
WScript.Quit 0
'********************************************************************
'*Процедура поиска в папке файлов с расширением lnk,
'*Производит замену старого пути на новый в ярлыках
'*при условии что будет найден ярлык со старым путём
'********************************************************************
Sub ReplaceShortcut (localFolderToSearch, targetToReplace, replacementTarget)
if objFSO.folderExists(localFolderToSearch) then
Set oFolder = objFSO.GetFolder(localFolderToSearch)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If LCase(objFSO.GetExtensionName(oFile.name)) = "lnk" Then
Set oLnk = oShell.CreateShortcut(oFile.path)
If instr(1, LCase(oLnk.TargetPath), targetToReplace, 1)<>0 Then
oLnk.TargetPath = replace(oLnk.TargetPath, targetToReplace, replacementTarget,1,-1,1)
oLnk.Save
'MsgBox "Отон он, нашёл его!"
End If
set oLnk=nothing
End If
Next
FindSubFolders localFolderToSearch
set oFiles=nothing
set oFolder=nothing
else
'folder does not even exist---do nothing?
end if
End Sub
'********************************************************************
'*Процедура поиска дисков у пользователя
'*Ищутся локальные диски, и как параметр отсылается на растерзание
'*процедуре поиска папок
'********************************************************************
Sub FindDrivers
For Each objDrive In objFSO.Drives
If objDrive.DriveType = 2 Then
If objDrive.IsReady Then
FindSubFolders objDrive.RootFolder
End If
End If
Next
End Sub
'********************************************************************
'*Ну и сама процедура поиска папок, с подпапками
'*Передаёт процедуре папки с аргументами (типа поищи тут) 
'********************************************************************
Sub FindSubFolders (objFolderForFind)
On Error Resume Next
For Each objFolder In objFolderForFind.SubFolders
If Err.Number = 0 Then
ReplaceShortcut objFolder,sarg2,sarg3
Else
Err.Clear
End If
Next
On Error Goto 0
End Sub |
Ремап дисков, на новый ресурс, сервер, путь и т.д.
Код: '*******************************************************************
'*Скрипт для замены старых путей в сетевых дисках на новые
'*Запускать с таким параметром /localOldTarget:"Старый путь" /localNewTarget:"Новый путь"
'*******************************************************************
On Error Resume Next
Dim sarg1,sarg2,objNetwork,colDrives,strNetworks,strDriveLette,strNetworkPath
With wscript.Arguments.Named
sarg1=LCase(.item("localOldTarget"))
sarg2=LCase(.item("localNewTarget"))
End With
'*******************************************************************
'*Проверим аргументы, переменные запуска
'*******************************************************************
If sarg1="" Or sarg2="" Then
MsgBox "Запускайте с такими параметрами:" & vbCr & vbCr &_
"/localOldTarget:""Старый путь"" /localNewTarget:""Новый путь""", vbinformation, "Внимание!"
'выйдем из скрипта, условие то нарушено!
WScript.Quit 0
End If
'*******************************************************************
'*Создадим объект Network, чтобы узнать какие диски смаплены
'*******************************************************************
Set objNetwork = CreateObject("Wscript.Network")
Set colDrives = objNetwork.EnumNetworkDrives
'*******************************************************************
'*Пробежимся по всем смапленным дискам и если условие localOldTarget
'*совпадёт, заменим на localNewTarget
'*******************************************************************
For i = 0 to colDrives.Count-1 Step 2
strDriveLetter = colDrives.Item(i)
strNetworkPath = LCase(colDrives.Item(i + 1))
'*Сохраним пути для будущего
strNetworks = strNetworks & strDriveLetter & " " & strNetworkPath & vbCr
'*Проведём манипуляции для проверки условий
If InStr (1, strNetworkPath, sarg1) <>0 Then
strNewPath = Replace (strNetworkPath, sarg1, sarg2)
'Отмапим чтоб с концами
objNetwork.RemoveNetworkDrive strDriveLetter, True, True
'Подождём малость
WScript.Sleep 3000
'И примапим так чтоб надолго
objNetwork.MapNetworkDrive strDriveLetter, strNewPath, True
'Ну и скажем на что поменяли...
strNewNetworks = "Заменён на:" & vbCr & strNewNetworks & strDriveLetter & " " & strNewPath & vbCr & vbCr
End If
Next
'MsgBox "На компьютере найдены сетевые диски" & vbCr &_
strNetworks & vbCr & vbCr & strNewNetworks, vbInformation, "Внимание!" |
Делал для своих нужд, переезжаем на новый сервер со сменой путей и т.д. |
Всего записей: 157 | Зарегистр. 27-08-2001 | Отправлено: 15:43 13-11-2008 | Исправлено: RuStn, 21:22 13-11-2008 |
|
