Total Commander

Код: Выделить всё

'=========================================================================
' Переименование файлов, представленных в файле-списке или в папке:
'   если имя начинается на {Word1}, то {Word1} заменяется на {Word2};
'   если имя начинается на {Word2}, то {Word2} удаляется из имени.
'
' Параметры:
' {файл-список}|{папка}
'
' Примеры параметров при вызове из TC:
' %L
' "%P"
'
' Автор - Batya
'=========================================================================
Option Explicit
'======== Изменяемые параметры ===========================================
Const Word1 = "печать_"       'Первое начало имен файлов
Const Word2 = "распечатано_"  'Второе начало имен файлов
'=========================================================================
Dim Mess, FSO, WSH, FF, IsFolder, F, LW1, LW2

On Error Resume Next
Main:CheckErr
On Error GoTo 0
MessBox Mess(3), 3
Quit 0

'Основная процедура
Sub Main
  SetMess
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set WSH = CreateObject("WScript.Shell")
  F = ""
  
  CheckParam
  
  LW1 = Len(Word1)
  LW2 = Len(Word2)
  
  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,  "Операция завершена."
  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 lFName, lNewPath
  lFName = FSO.GetFileName(pPath)
  If Left(LCase(lFName), LW1) = LCase(Word1) Then
    lNewPath = FSO.GetParentFolderName(pPath) & "\" & Word2 & Mid(lFName, LW1 + 1)
    FileMove pPath, lNewPath
  ElseIf Left(LCase(lFName), LW2) = LCase(Word2) Then
    lNewPath = FSO.GetParentFolderName(pPath) & "\" & Mid(lFName, LW2 + 1)
    FileMove pPath, lNewPath
  End If
End Sub

'Перемещение файла
Sub FileMove(pPath, pNewPath)
  FSO.MoveFile pPath, pNewPath
End Sub

'Обработка папки
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 = "Возникла ошибка № " & Err.Number & ":" & vbNewLine & Err.Description
  If F <> "" Then lMess = lMess & vbNewLine & vbNewLine & "Файл\папка:" & 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 WSH  = Nothing
  Set FSO  = Nothing
  WScript.Quit pExitCode
End Sub

Код: Выделить всё

[U][N1][n][N2-]