Home   •   Добро пожаловать!   •   Скрипты и программы

Скрипты и программы

Скрипт VBA для пакетного переименования файлов по маске, заданной в листе Excel:

Скачать "File Renamer" в формате Excel xlsm

Function renameFiles() 'Функция переименования файлов в текущем каталоге
 
On Error GoTo ErrHandler: ' Действие при появлении ошибки (взамен стандартного сообщения об ошибке)
 
Dim folderPath As String ' Абсолютный Путь до каталога в котором расположен этот файл Excel
Dim filePath As String ' Абсолютный Путь до этого файла Excel, вместе с именем самого файла
Dim projectCode As String ' Шифр проекта, который будет использован в именах файлов
Dim oldProjectCode As String ' Предыдущий шифр проекта (сохраняетсяв в таблице файла Excel после каждого переименования)
Dim fileName As String ' Имя существующего файла в текущем каталоге (преобразованое в строковой вид)
Dim newFileName As String ' Новое имя файла (собранное из нового шифра проекта и части старого имени файла)
Dim tempFileName As String ' Часть имен файлов-шаблонов, которая будет заменятся
' Возможные расширения файлов подлежащих переименованию
Dim fileExtension1 As String
Dim fileExtension2 As String
Dim fileExtension3 As String
 
 
' Объекты для работы с файловой системой:
Dim oFolder As Object
Dim oFile As Object
Dim oFSO As Object
 
' Определение переменных:
folderPath = Application.ActiveWorkbook.Path ' Получить полный путь каталога
filePath = Application.ActiveWorkbook.FullName ' Получить полный путь файла
projectCode = Range(ConfigForm1.projectCode_cell.Value).Value  ' Получить шифр проекта из заданной ячейки таблицы
oldProjectCode = Range(ConfigForm1.oldProjectCode_cell.Value).Value  ' Получить предыдущий шифр проекта из заданной ячейки таблицы
tempFileName = Range(ConfigForm1.tempFileName_cell.Value).Value ' Получить заменяемую часть для файлов-шаблонов из заданной ячейки таблицы
 
' Возможные расширения файлов подлежащих переименованию (выбираются из ячеек таблицы)
 
 
fileExtension1 = Range(ConfigForm1.fileExtension1_cell.Value).Value
fileExtension2 = Range(ConfigForm1.fileExtension2_cell.Value).Value
fileExtension3 = Range(ConfigForm1.fileExtension3_cell.Value).Value
 
Set oFSO = CreateObject("Scripting.FileSystemObject") ' Создание объекта файловой системы
Set oFolder = oFSO.GetFolder(folderPath) ' Получение доступа к целевому каталогу (текущий каталог)
 
    ' Начало основного Цикла перебора имен всех файлов в целевом каталоге:
    For Each oFile In oFolder.Files
 
    fileName = CStr(oFile.Name) ' Преобразование типа данных "Объект (имяФайла) -> Строка (имя файла)"
 
    If Not fileName Like oldProjectCode & "*" Then ' Если имя файла не соответствует старому (предыдущему) шифру проекта
        '  Если имя файла имеет одно из указанных расширений (или содержит часть указанного расширения. Например *.doc[x, m])
        If fileName Like "*." + fileExtension1 + "*" Or fileName Like "*." + fileExtension2 + "*" Or fileName Like "*." + fileExtension3 + "*" Then
              '  Если в имени файла содержится строка указанная в ячейке (например для файлов-шаблонов "НОМЕР-МАРКА")
              If fileName Like tempFileName & "*" Then
 
                 ' Сборка нового имени файла (замена "НОМЕР-МАРКА" на новый ШифрПроекта)
                 newFileName = Replace(fileName, tempFileName, projectCode)
                 oFile.Name = newFileName ' Переименование реального файла
 
    End If
        End If
                End If
 
    ' Если имя файла содержит старый (предыдущий) шифр проекта И заданный ШифрПроекта НЕравен старому ШифруПроекта
    If fileName Like oldProjectCode + ".*" And projectCode <> oldProjectCode Then
 
        ' Сборка нового имени файла (замена старого ШифраПроекта на новый ШифрПроекта)
        newFileName = Replace(fileName, oldProjectCode, projectCode)
        oFile.Name = newFileName ' Переименование реального файла
 
    End If
 
 
' Окно Взамен стандартного сообщения об ошибке
ErrHandler:
If Err.Number = 58 Then ' Если Код ошибки 58 "файл с таким именем уже существует в целевом каталоге" то
' Вывод окна с Сообщением об ошибке
MsgBox "Файл с именем:" & vbNewLine & "'" + newFileName + "'" + vbNewLine & "уже существует в текущем каталоге:" & vbNewLine & folderPath, vbCritical
End If
Resume Next ' После квитирования сообщения выполнять код далее
 
' MsgBox "---"
 
    Next ' Следующий проход по циклу (пока в целевом каталоге есть еще не обработанные файлы)
 
 
Range(ConfigForm1.oldProjectCode_cell.Value).Value = projectCode ' Запись в ячейку со СтарымШифромПроекта значения НовогоШифраПроекта
 
 
' Вывод окна с Сообщением об успешном переименовании файлов
MsgBox "Полный путь каталога: " & vbNewLine & " " & vbNewLine & folderPath & vbNewLine & " " & vbNewLine & "Файлы в текущем каталоге переименованы успешно", vbInformation + vbOKOnly
 
 
 
End Function
 
 

Published on