Option Explicit
' API-функция для измерения времени обработки
#If VBA7 Then
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As LongLong
#Else
Private Declare Function GetTickCount Lib "kernel32" () As Long
#End If
#If VBA7 Then
Dim nTimeCntr As LongLong ' Счетчик времени обработки
#Else
Dim nTimeCntr As Long ' Счетчик времени обработки
#End If
Dim PrB As ProgressIndicator ' Класс для визуализации процесса замены
Dim scolFilePaths As New Collection ' Пути ко всем файлам, которые должна обрабатывать программа
Dim scolFolders As New Collection ' Пути ко все вложенным каталогам
Dim scolFindText As New Collection ' Коллекция со строками поиска
Dim scolReplaceText As New Collection ' Коллекция со строками замены
Dim sLogFilePath As String ' Путь к лог-файлу
Dim sPath As String ' Путь к исходному каталогу
Dim sMask As String ' Маска поиска файлов
' Перечисление для определения диапазона поиска файлов.
' Можно обойтись и без него, но зачем?
Enum WhichFilesProceed
wfpOnlyInRootFolder = 0
wfpInRootAndSubFolders = 1
wfpOnlyInSubFolders = 2
End Enum
Private Sub btnClose_Click()
Unload SRForm
End Sub
Private Sub btnReplace_Click()
Set PrB = New ProgressIndicator
nTimeCntr = GetTickCount ' Запоминаем время начала обработки
Application.Visible = False
Dim sFilePath ' Путь к файлу из коллекции полей
Dim sFindText ' Строка поиска из коллекции
Dim sReplaceText ' Строка замены из коллекции
Dim oCurrDoc As Document ' Документ, в котором производим замену
Dim oRngStory As Range ' Объект для перебора частей документа
Dim i As Integer ' Счетчик цикла
Dim bShowFieldCode As Boolean ' Флаг, запоминающий состояние отображения полей в документе
Dim iOpenedFilesCntr As Integer ' Счетчик открытых документов
Dim iReadOnlyFilesCntr As Integer ' Счетчик документов, доступных только для чтения
sLogFilePath = sPath & Format(Date, "dd-mm-yy") & "_" & Format(Time, "hh-MM-ss") & "_пакетная_замена.log"
FixInLogFile sLogFilePath, Format(Date, "dd mmmm yyyy") & " " & Time
' получаем имена файлов
If obtnFilesAndSubfolders.Value Then
Call GetFilePaths(sPath, sMask, wfpInRootAndSubFolders)
FixInLogFile sLogFilePath, "Обрабатываются " & StrConv(obtnFilesAndSubfolders.Caption, vbLowerCase)
ElseIf obtnOnlyFiles.Value Then
Call GetFilePaths(sPath, sMask, wfpOnlyInRootFolder)
FixInLogFile sLogFilePath, "Обрабатываются " & StrConv(obtnOnlyFiles.Caption, vbLowerCase)
ElseIf obtnOnlySubfolders.Value Then
Call GetFilePaths(sPath, sMask, wfpOnlyInSubFolders)
FixInLogFile sLogFilePath, "Обрабатываются " & StrConv(obtnOnlySubfolders.Caption, vbLowerCase)
End If
FixInLogFile sLogFilePath, vbCr & String(35, "*")
FixInLogFile sLogFilePath, "Параметры замены"
FixInLogFile sLogFilePath, String(35, "*")
FixInLogFile sLogFilePath, vbTab & "Исходный каталог: " & sPath
FixInLogFile sLogFilePath, vbTab & "Маска: " & sMask
FixInLogFile sLogFilePath, vbTab & "Учитывать регистр: " & IIf(chbMatchCase.Value, "Да", "Нет")
FixInLogFile sLogFilePath, vbTab & "Только слово целиком: " & IIf(chbMatchWholeWord.Value, "Да", "Нет")
FixInLogFile sLogFilePath, vbTab & "Изменять надписи: " & IIf(chbProcTextboxes.Value, "Да", "Нет")
FixInLogFile sLogFilePath, vbTab & "Изменять объекты WordArt: " & IIf(chbProcWordArt.Value, "Да", "Нет")
FixInLogFile sLogFilePath, vbTab & "Изменять гиперссылки: " & IIf(chbProcHyperLinks.Value, "Да", "Нет")
FixInLogFile sLogFilePath, String(35, "*") & vbCr & String(35, "*") & vbCr
If scolFilePaths.Count = 0 Then
FixInLogFile sLogFilePath, Time & " Файлы, соответствующие заданной маске, в указанных местах не найдены."
Exit Sub ' Если файлов нет, то выходим из процедуры
End If
Dim nFileCounter As Long ' Счетчик файлов для прогресс-бара
Call PrB.Show("Макрос пакетной замены")
PrB.ShowPercents = True
Call PrB.StartNewAction(L1_txt:="Подготовка…")
For Each sFilePath In scolFilePaths
' Открываем каждый файл для выполнения замены
' При этом проверяем доступность файла для чтения
If Not IsFileReadOnly(CStr(sFilePath)) Then
Set oCurrDoc = Documents.Open(CStr(sFilePath), AddToRecentFiles:=False)
nFileCounter = nFileCounter + 1
' Изменяем прогресс-бар
PrB.CurAction nFileCounter, scolFilePaths.Count, _
"Открытие документа " & nFileCounter & " из " & scolFilePaths.Count, " ", " "
' Делаем запись в лог-файл
FixInLogFile sLogFilePath, CStr(Time) & " Открыт для проведения замены:" & " " & sFilePath
' Счетчик открытых документов
iOpenedFilesCntr = iOpenedFilesCntr + 1
Else
' Делаем запись в лог файл
FixInLogFile sLogFilePath, CStr(Time) & " Доступен только для чтения:" & " " & sFilePath
' Счетчик документов, доступных только для чтения
iReadOnlyFilesCntr = iReadOnlyFilesCntr + 1
' Переход к следующему файлу
GoTo NextFile
End If
' Fix the skipped blank Header/Footer problem
' Не знаю, что это означает, но пусть будет
Dim lngJunk As Integer
lngJunk = oCurrDoc.Sections(1).Headers(1).Range.StoryType
' Включаем или отключаем отображение кодов полей вместо значений для замены в гиперссылках
' Состояние отображения кодов сохраняем, чтобы восстановить после обработки документа
bShowFieldCode = oCurrDoc.Windows(1).View.ShowFieldCodes
oCurrDoc.Windows(1).View.ShowFieldCodes = chbProcHyperLinks.Value
' Сброс параметров поиска
Call ResetFRParameters
' Перебираем все составляющие документа
For i = 1 To scolFindText.Count
' Читаем из коллекций строки поиска и замены
sFindText = scolFindText.Item(i)
sReplaceText = scolReplaceText(i)
' Делаем запись в лог-файл
FixInLogFile sLogFilePath, vbTab & Time & " Найти: " & sFindText & vbTab & "Заменить на: " & sReplaceText
' Изменяем прогресс-бар
PrB.CurAction nFileCounter, scolFilePaths.Count, _
"Выполнение замены", Mid(sFilePath, _
InStrRev(sFilePath, "\") + 1), _
"Найти: " & sFindText & vbTab & "Заменить: " & sReplaceText
' Перебираем все структурные элементы документа
For Each oRngStory In oCurrDoc.StoryRanges
Do
SrcAndRplInStory oRngStory, sFindText, sReplaceText, chbMatchCase.Value, chbMatchWholeWord.Value
On Error Resume Next
' Оператор, необходимый для поиска и замены в надписях, которые находятся
' во всевозможных колонтитулах страниц и сносках
Select Case oRngStory.StoryType
Case 6 To 11
Call ReplaceInShapes(oRngStory, sFindText, sReplaceText)
Case Else
Call ReplaceInShapes(oRngStory, sFindText, sReplaceText)
End Select
On Error GoTo 0
Set oRngStory = oRngStory.NextStoryRange
Loop Until oRngStory Is Nothing
Next oRngStory
Next i
' Восстанавливаем состояние отображения полей
oCurrDoc.Windows(1).View.ShowFieldCodes = bShowFieldCode
' Закрываем файл с сохранением изменений
oCurrDoc.Close Savechanges:=wdSaveChanges
NextFile:
Next sFilePath
' Записываем результаты работы в лог-файл
FixInLogFile sLogFilePath, vbCr & vbCr & String(35, "*") & vbCr & String(35, "*")
FixInLogFile sLogFilePath, "Обработано " & iOpenedFilesCntr & " документов"
' Если были документы, доступные только для чтения, то делаем запись о них в лог-файл
If CBool(iReadOnlyFilesCntr) Then _
FixInLogFile sLogFilePath, iReadOnlyFilesCntr & " документов доступны только для чтения"
FixInLogFile sLogFilePath, "Затрачено " & CStr((GetTickCount - nTimeCntr) / 1000) & " сек."
' Прячем прогресс-бар
PrB.Hide
' Показываем приложение
Application.Visible = True
' Сообщение с результатами работы и предложением просмотреть лог-файл
If MsgBox("Поиск и замена завершены. Обработано " & CStr(iOpenedFilesCntr + iReadOnlyFilesCntr) & " документов." & vbCr & _
"Результаты занесены в лог-файл " & sLogFilePath & "." & vbCr & _
"Открыть лог-файл для чтения?", vbInformation + vbYesNo, "Макрос пакетной замены") = vbYes Then
Shell "notepad """ & sLogFilePath & """"
End If
' Выгружаем форму
Unload Me
End Sub
' Получение списка файлов
Sub GetFilePaths(sRootFolderPath As String, sMask As String, WhichFiles As WhichFilesProceed)
Dim FSO As New FileSystemObject
Dim oFldr As Folder
Dim oSubFldr As Folder
Dim sFileName As String
Dim i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
If Right(sRootFolderPath, 1) <> "\" Then sRootFolderPath = sRootFolderPath & "\"
' Получаем имена файлов из корневого каталога
If WhichFiles = wfpOnlyInRootFolder Or WhichFiles = wfpInRootAndSubFolders Then
sFileName = Dir(sRootFolderPath & sMask)
While Len(sFileName) > 0
scolFilePaths.Add sRootFolderPath & sFileName
sFileName = Dir
Wend
End If
' Получаем имена файлов из всех подкаталогов
If WhichFiles = wfpOnlyInSubFolders Or WhichFiles = wfpInRootAndSubFolders Then
' Пути всех вложенных каталогово записываем в коллекцию scolFolders
Call GetAllSubFolders(sRootFolderPath)
For i = 1 To scolFolders.Count
Set oFldr = FSO.GetFolder(scolFolders(i))
sFileName = Dir(oFldr.Path & "\" & sMask)
While Len(sFileName) > 0
scolFilePaths.Add oFldr.Path & "\" & sFileName
sFileName = Dir
Wend
Next i
End If
Set FSO = Nothing: Set oFldr = Nothing: Set oSubFldr = Nothing
End Sub
' Проверка файла на возможность записи в него
Function IsFileReadOnly(sFilePath As String) As Boolean
Dim FSO As New FileSystemObject
Dim oFile As File
Dim FileAttrs
Set oFile = FSO.GetFile(sFilePath)
FileAttrs = oFile.Attributes
IsFileReadOnly = (Right(CStr(Hex(FileAttrs)), 1) = 1)
Set FSO = Nothing: Set oFile = Nothing
End Function
Sub FixInLogFile(sLogFilePath As String, sMessage As String)
Open sLogFilePath For Append As #1
Print #1, sMessage
Close #1
End Sub
' Основная процедура замены
Sub SrcAndRplInStory(ByVal rngstory As Word.Range, _
ByVal strSearch As String, _
ByVal strReplace As String, _
ByVal bMatchCase As Boolean, _
ByVal bMatchWholeWord As Boolean)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.MatchCase = bMatchCase
.MatchWholeWord = bMatchWholeWord
.Replacement.Text = strReplace
.Execute Replace:=wdReplaceAll
End With
End Sub
' Сброс параметров замены
Sub ResetFRParameters()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub
' Процедура замены в надписях
Sub ReplaceInShapes(ByVal oShpRange As Range, _
ByVal strSearch As String, _
ByVal strReplace As String)
Dim oShp As Shape ' Объект для перебора надписей в документе
Dim oInShp As InlineShape
' Надписи, расположенные поверх текста
If oShpRange.ShapeRange.Count > 0 And chbProcTextboxes.Value Then
For Each oShp In oShpRange.ShapeRange
' oShp.Select
' Debug.Assert False
If oShp.TextFrame.HasText Then
SrcAndRplInStory oShp.TextFrame.TextRange, strSearch, strReplace, chbMatchCase.Value, chbMatchWholeWord.Value
ElseIf oShp.Type = msoTextEffect And chbProcWordArt.Value Then
oShp.TextEffect.Text = Replace(oShp.TextEffect.Text, strSearch, strReplace, , , Abs(CInt(chbMatchCase.Value)))
End If
Next oShp
End If
' Замена в объектах WordArt
If oShpRange.InlineShapes.Count > 0 And chbProcTextboxes.Value And chbProcWordArt.Value Then
For Each oInShp In oShpRange.InlineShapes
If oInShp.TextEffect.Text <> "" Then
oInShp.TextEffect.Text = Replace(oInShp.TextEffect.Text, strSearch, strReplace, , , Abs(CInt(chbMatchCase.Value)))
End If
Next oInShp
End If
End Sub
Private Sub UserForm_Initialize()
Dim i As Integer
sPath = ThisDocument.Tables(1).Cell(2, 1).Range.Text
' С помощью регулярных выражений проверяем, что в первой таблице находится путь к файлу.
Dim oRegExp As Object
Set oRegExp = CreateObject("VBScript.RegExp")
oRegExp.IgnoreCase = True
oRegExp.Pattern = "(\b[a-z]:|\\\\[a-z0-9]+)\\([^/:*?""<>|\r\n]*\\)?"
If Not oRegExp.Test(sPath) Then
MsgBox "Выражение в первой таблице не может быть обработано как путь к файлу или каталогу", vbOKOnly + vbInformation, "Пакетная замена"
ThisDocument.Tables(1).Cell(2, 1).Range.Select
Unload Me
End If
' Извлекаем путь и маску, указанные в первой таблице
sPath = Left(sPath, Len(sPath) - 2)
sMask = Mid(sPath, InStrRev(sPath, "\") + 1)
sPath = Replace(sPath, sMask, "")
lblPath.Caption = "Путь: " & sPath
lblMask.Caption = "Маска для файлов: " & sMask
' Получаем пары для поиска и замены
For i = 2 To ThisDocument.Tables(2).Rows.Count
scolFindText.Add Left(ThisDocument.Tables(2).Cell(i, 1).Range.Text, Len(ThisDocument.Tables(2).Cell(i, 1).Range.Text) - 2), CStr(i - 2)
scolReplaceText.Add Left(ThisDocument.Tables(2).Cell(i, 2).Range.Text, Len(ThisDocument.Tables(2).Cell(i, 2).Range.Text) - 2), CStr(i - 2)
Next i
End Sub
' Пути ко всем вложенным папкам
Sub GetAllSubFolders(sPath As String)
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim FSO As New FileSystemObject
Set objFolder = FSO.GetFolder(sPath)
If objFolder Is Nothing Then Exit Sub
For Each objSubFolder In objFolder.SubFolders
If objSubFolder.SubFolders.Count <> 0 Then Call GetAllSubFolders(objSubFolder.Path)
scolFolders.Add objSubFolder.Path
Next
End Sub
|