'=========================================================================
' Групповая замена свойств ярлыков.
'
' Параметры:
' {файл-список ярлыков}|{папка с ярлыками}
'
' Примеры параметров при вызове из 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

Dim HTA: HTA = GetPath("%Temp%\" & FSO.GetTempName)
FSO.CreateTextFile(HTA).Write "<html><head><title>" & Mess(0) &_
"</title><meta http-equiv=X-UA-Compatible content=IE=11/><HTA:APPLICATION" &_
" icon=FXSRESM.dll BorderStyle=raised InnerBorder=no SingleInstance=yes/>" &_
"<style type=text/css> * {margin:0;padding:2;border:solid 0px menu;}body{" &_
"overflow:hidden;}textarea {background-color:transparent;resize:inherit;"  &_
"position:absolute;overflow-x:hidden;overflow-y:auto;width:100%;height:100"&_
"%;}</style><script type=text/jscript language=JScript>W=self.screen.avail"&_
"Width;H=self.screen.availHeight;self.moveTo(W*3/16,H*3/16);self.resizeTo" &_
"(W*5/8,H*5/8);document.onkeydown=function(){if(event.keyCode==27)self."   &_
"close();if(event.keyCode==13){if(window.screenX==0){self.moveTo(W*3/16,H" &_
"*3/16);self.resizeTo(W*5/8,H*5/8);}else{self.moveTo(0,0);self.resizeTo(W" &_
",H);}}}</script></head><body bgcolor=menu><textarea rows=30 cols=60 wrap" &_
"=hard autofocus readonly>" & Mess(9) & Msg & "</textarea></body></html>"
WSH.Run "%WINDIR%\SYSTEM32\mshta.exe " & HTA,, True : FSO.GetFile(HTA).Delete