Batya
|
 Posted: Tue Dec 29, 2009 18:37 Post subject: |
 |
|
Slaider
Наконец-то готово:
| Code: | '==========================================================================
' Копирование пар файлов в новую папку согласно информации из txt-файла
' Параметры:
' {обрабатываемая папка} {целевая папка}
'
' Автор - Batya
'==========================================================================
'Включаем режим необходимости объявлять переменные
Option Explicit
'======== Изменяемые параметры ============================================
'Задаем константы
Const TXTExt = "TXT" 'Расширение описательных файлов
Const SearchStr = "Document group:" 'Искомая строка
'==========================================================================
'Объявляем переменные
Dim FSO, WSH, Mess, Folder1, Folder2, Files, F, P, Text, S
'Выполняем процедуру формирования массива сообщений
SetMess
'Объявляем служебные объекты
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
'Включаем режим ручной обработки ошибок
On Error Resume Next
'Выполняем процедуру проверки входых параметров. Затем проверяем ошибки.
CheckParam:CheckErr
'Объявляем массив рабочих файлов
Set Files = CreateObject("Scripting.Dictionary")
'Выполняем процедуру получения массива рабочих файлов. Затем проверяем ошибки.
GetFiles Folder1, TXTExt:CheckErr
'Для всех файлов в массиве рабочих файлов ...
For Each F In Files
'Выполняем функцию получения парного файла. Затем проверяем ошибки.
P = GetPair(F, TXTExt):CheckErr
'Если парный файл найден ...
If P <> "" Then
'Читаем текст из парного файла. Затем проверяем ошибки.
Text = GetText(P):CheckErr
'Получаем необходимый текст из парного файла
S = Trim(RegExpSearch(Text, "(" & SearchStr & ")(\s*)([^\n\r]+)", 3))
'Если текст найден ...
If S <> "" Then
'Формируем путь папки для копирования пары файлов
S = Folder2 & "\" & S
'Если папки не существует, создаём её
If Not FSO.FolderExists(S) Then CreateFolder S:CheckErr
'Копируем рабочий файл. Затем проверяем ошибки.
CopyFile F, S & "\":CheckErr
'Копируем парный файл. Затем проверяем ошибки.
CopyFile P, S & "\":CheckErr
End If
End If
'Переходим к следующему файлу
Next
'Выводим сообщение о завершении работы скрипта
MessBox Mess(5), 3
'Выходим без ошибки - код выхода - 0
Quit 0
'Функция разворачивает путь файла (раскрываем системные переменные). Параметры:
' pPath - путь к файлу
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
'Функция возвращает текстове содержимое файла. Параметры:
' pPath - путь к файлу
Function GetText(pPath)
GetText = FSO.OpenTextFile(pPath, 1, False).ReadAll
End Function
'Процедура создания папки.
'Вынесено в отдельную процедуру для изменения при необходимости способа создания
Sub CreateFolder(pPath)
FSO.CreateFolder pPath
End Sub
'Процедура копирования файла
'Вынесено в отдельную процедуру для изменения при необходимости способа копирования
Sub CopyFile(pFilePath, pFolder)
FSO.CopyFile pFilePath, pFolder
End Sub
'Процедура получения массива рабочих файлов. Параметры:
' pPath - путь к папке с рабочими файлами;
' pExt - расширение парных файлов - пропускаем такие файлы
Sub GetFiles(pPath, pExt)
'Объявляем переменные
Dim lF
'Для всех файлов в папке ...
For Each lF In FSO.GetFolder(pPath).Files
'Если расширение файла не совпадает с расширением для парных файлов,
' то добавляем этот файл к массиву рабочих файлов
'(Сравниваем, приведя текст к одному регистру - верхнему)
If UCase(FSO.GetExtensionName(lF)) <> UCase(pExt) Then Files.Add lF.Path, ""
'Переходим к следующему файлу
Next
'Для всех вложенных папок ...
For Each lF In FSO.GetFolder(pPath).SubFolders
'Добавляем к массиву рабочих файлов файлы из вложенной папки
GetFiles lF.Path, pExt
'Переходим к следующей папке
Next
End Sub
'Функция получения пары для файла. Параметры:
' pPath - путь к файлу;
' pExt - расширение парного файла
Function GetPair(pPath, pExt)
'Объявляем переменные
Dim lF, lPF, lPath
'Получаем имя родительской папки
lPF = FSO.GetParentFolderName(pPath)
'Начало пути, которое должно быть у парного файла -
' путь родительской папки + имя файла без расширения
lPath = lPF & "\" & FSO.GetBaseName(pPath)
'Для всех файлов в родительской папке ...
For Each lF In FSO.GetFolder(lPF).Files
'Если расширение файла совпадает с расширением для парных файлов ...
'(Сравниваем, приведя текст к одному регистру - верхнему)
If UCase(FSO.GetExtensionName(lF.Path)) = UCase(pExt) Then
'Если начало пути для парного файла = началу пути рассматриваемого файла ...
If UCase(lPath) = UCase(Left(lF.Path, Len(lPath))) Then
'значит пару нашли
GetPair = lF.Path
'Выходим из функции
Exit Function
End If
End If
'Переходим к следующему файлу
Next
End Function
'Функция поиска с помощью регулярных выражений. Параметры:
' pText - текст, в котором ищем;
' pFind - искомое выражение;
' pNum - номер возвращаемого элемента найденного
Function RegExpSearch(pText, pFind, pNum)
'Объявляем переменные
Dim regEx, Matches
'Объявляем объект рег. выражений
Set regEx = New RegExp
'Задаём выражение для поиска
regEx.Pattern = pFind
'Указываем игнорирование регистра символов
regEx.IgnoreCase = True
'Указываем поиск единственного искомого
regEx.Global = False
'Выполняем поиск в тексте
Set Matches = regEx.Execute(pText)
'Если что-либо найдено, возвращаем из найденного необходимую часть
If Matches.Count > 0 Then RegExpSearch = Matches(0).Submatches(pNum - 1)
End Function
'Процедура проверки входных параметров
Sub CheckParam
'Работаем с объектом WScript
With WScript
'Если параметров нет, генерим ошибку
If .Arguments.Count = 0 Then Err.Raise vbObjectError + 1, "", Mess(1)
'Если параметров меньше 2, генерим ошибку
If .Arguments.Count < 2 Then Err.Raise vbObjectError + 2, "", Mess(2)
'Первый параметр (индекс 0) - обрабатываемая папка
Folder1 = GetPath(.Arguments(0))
'Второй параметр (индекс 1) - целевая папка
Folder2 = GetPath(.Arguments(1))
End With
'Если обрабатываемая папка не существует, генерим ошибку
If Not FSO.FolderExists(Folder1) Then Err.Raise vbObjectError + 3, "", Mess(3)
'Если целевая папка не существует, генерим ошибку
If Not FSO.FolderExists(Folder2) Then Err.Raise vbObjectError + 4, "", Mess(4)
End Sub
'Процедура задания массива сообщений
Sub SetMess
'Объявляем ассоциированный массив
Set Mess = CreateObject("Scripting.Dictionary")
'Работаем с объектом Mess
With Mess
'Задаем сообщения
.Add -1, "Возникла ошибка № "
.Add 0, "Копирование пар файлов"
.Add 1, "Не указаны параметры!"
.Add 2, "Указаны не все параметры!"
.Add 3, "Указанная обрабатываемая папка не существует!"
.Add 4, "Указанная целевая папка не существует!"
.Add 5, "Операция завершена"
End With
End Sub
'Функция вывода сообщения. Параметры:
' pMess - текст сообщения;
' pMode - режим сообщения
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 CheckErr
'Есть ли ошибка?
If Err.Number <> 0 Then
'Выводим сообщение об ошибке
MessBox Mess(-1) & Err.Number & ":" & vbNewLine & Err.Description, 1
'Завершаем скрипт с кодом ошибки
Quit Err.Number
End If
End Sub
'Процедура выхода. Параметры:
' pQuitCode - код выхода (ошибки)
Sub Quit(pQuitCode)
'Снимаем объявление объектов
Set Files = Nothing
Set Mess = Nothing
Set WSH = Nothing
Set FSO = Nothing
'Выходим, указав код выхода
WScript.Quit pQuitCode
End Sub |
_________________
Нет, я не сплю. Я просто медленно моргаю.
Last edited by Batya on Thu Mar 04, 2010 21:37; edited 2 times in total |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
