Batya
|
 Posted: Thu Oct 22, 2009 11:14 Post subject: |
 |
|
Готово:
| Code: | '=========================================================================
' Групповая замена свойств ярлыков.
'
' Параметры:
' {файл-список ярлыков}|{папка с ярлыками}
'
' Примеры параметров при вызове из TC:
' %L
' "%P"
'
' Автор - Batya
'=========================================================================
Option Explicit
Dim Mess, FSO, WSH, FF, IsFolder, F, FindStr, ReplStr, Res, Msg, K
On Error Resume Next
Main:CheckErr
On Error GoTo 0
If Res.Count > 0 Then
For Each K In Res.Keys
Msg = Msg & vbNewLine & vbNewLine & K & " - " & Res(K)
Next
Else
Msg = vbNewLine & vbNewLine & Mess(10)
End If
WSH.Popup Mess(9) & Msg, 0, Mess(0)
Quit 0
'Основная процедура
Sub Main
SetMess
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
Set Res = CreateObject("Scripting.Dictionary")
F = ""
CheckParam
FindStr = InputBox(Mess(3), Mess(0)):If FindStr = "" Then Quit 0
ReplStr = InputBox(Mess(4), Mess(0)):If ReplStr = "" Then Quit 0
If IsFolder Then
FolderProc FF
Else
For Each F In Split(FSO.OpenTextFile(FF).ReadAll, vbNewLine)
If F <> "" Then
F = GetPath(F)
If FSO.FileExists(F) Then
FileProc F
ElseIf FSO.FolderExists(F) Then
FolderProc F
End If
End If
Next
End If
End Sub
'Массив сообщений
Sub SetMess
Set Mess = CreateObject("Scripting.Dictionary")
With Mess
.Add 0, "Групповая замена свойств ярлыков"
.Add 1, "Не указаны параметры!"
.Add 2, "Первый параметр не является файлом-списком или папкой!"
.Add 3, "Введите искомый текст:"
.Add 4, "Введите текст на замену:"
.Add 5, "Выполнена замена:"
.Add 6, "Возникла ошибка:" & vbNewLine
.Add 7, "Возникла ошибка № "
.Add 8, "Файл\папка:"
.Add 9, "Результат операции:"
.Add 10, "Замен не произошло."
End With
End Sub
'Проверка входных параметров
Sub CheckParam
If WScript.Arguments.Count = 0 Then Err.Raise vbObjectError + 1, "", Mess(1)
FF = GetPath(WScript.Arguments(0))
If Not FSO.FileExists(FF) Then
If Not FSO.FolderExists(FF) Then
Err.Raise vbObjectError + 2, "", Mess(2)
Else
IsFolder = True
End If
Else
IsFolder = False
End If
End Sub
'Обработка файла-ярлыка
Sub FileProc(pPath)
Dim lExt, LNK
On Error Resume Next
lExt = FSO.GetExtensionName(pPath)
If LCase(lExt) = "lnk" Then
Msg = ""
With WSH.CreateShortcut(pPath)
.TargetPath = ReplaceIn("TargetPath", .TargetPath)
.IconLocation = ReplaceIn("IconLocation", .IconLocation)
.WorkingDirectory = ReplaceIn("WorkingDirectory", .WorkingDirectory)
.Description = ReplaceIn("Description", .Description)
.Save
End With
If Msg <> "" Then Res.Add pPath, Mess(5) & Msg
If Err.Number <> 0 Then Res.Add pPath, Mess(6) & " " & Err.Description
Msg = ""
End If
On Error GoTo 0
End Sub
'Замена в строке
Function ReplaceIn(pType, pStr)
If InStr(1, pStr, FindStr, 1) > 0 Then
Msg = Msg & vbNewLine & " " & pType & ": " & pStr & " -> "
ReplaceIn = Replace(pStr, FindStr, ReplStr, 1, 1, 1)
Msg = Msg & ReplaceIn
Else
ReplaceIn = pStr
End If
End Function
'Обработка папки
Sub FolderProc(pPath)
Dim loF
Set loF = FSO.GetFolder(pPath)
For Each F In loF.SubFolders
F = F.Path
FolderProc F
Next
For Each F In loF.Files
F = F.Path
FileProc F
Next
Set loF = Nothing
End Sub
'Разложить путь при наличии переменных окружения
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
'Проверка, нет ли ошибок
Sub CheckErr
Dim lMess
lMess = Mess(7) & Err.Number & ":" & vbNewLine & Err.Description
If F <> "" Then lMess = lMess & vbNewLine & vbNewLine & Mess(8) & vbNewLine & F
If Err.Number <> 0 Then
MessBox lMess, 1
Quit Err.Number
End If
End Sub
'Сообщение
Function MessBox(pMess, pMode)
Dim lIcon
Select Case pMode
Case 1 lIcon = vbCritical + vbOKOnly
Case 2 lIcon = vbExclamation + vbOKOnly
Case 3 lIcon = vbInformation + vbOKOnly
End Select
MessBox = MsgBox(pMess, lIcon, Mess(0))
End Function
'Выход
Sub Quit(pExitCode)
Set Mess = Nothing
Set Res = Nothing
Set WSH = Nothing
Set FSO = Nothing
WScript.Quit pExitCode
End Sub |
Примечание! Странно, у некоторых файлов в процессе редактирования ярлыка уже при изменении в поле "Объект" сразу меняется "Рабочая папка".
_________________
Нет, я не сплю. Я просто медленно моргаю. |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
