Скопируйте все замены, сделанные в макросе, в отдельный файл в виде отчета с номером страницы

ProgramBox

Скопируйте все замены, сделанные в макросе, в отдельный файл в виде отчета с номером страницы

Post author:admin
Запись опубликована:6 августа, 2022
Post category:Вопросы по программированию

#vba #ms-word

Вопрос:

В настоящее время я изучаю, как создавать макросы в word для поиска ошибок, таких как пробелы между словами, после предложений, код для этого широко доступен, и я использую приведенный ниже код, чтобы помочь выявить любые ошибки (я как бы смешал несколько макросов вместе, это не безупречно, поскольку они не работаюткажется, они хорошо взаимодействуют друг с другом, но это не мой вопрос).

Я пытаюсь выяснить, как отобразить номер страницы чего-либо, найденного в find and replace, и фрагмент текста, который он хочет заменить, в отчете в конце документа или, в идеале, в отдельном пустом, в каком-то удобочитаемом формате, я не могу найти никаких примеровэто и интересно, возможно ли это? Спасибо!

 
Option Explicit
Sub SpacingFixer()
 'If something goes wrong, go to the errorhandler
    On Error GoTo ERRORHANDLER
    'Current page variable
    CurPage = Selection.Information(wdActiveEndAdjustedPageNumber)
    'Checks the document for excessive spaces between words
    With Selection
        .HomeKey Unit:=wdStory
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            'Here is where it is actually looking for spaces between words
            .Text = " [ ]@([! ])"
            'This line tells it to replace the excessive spaces with one space
            .Replacement.Text = " 1"
            .MatchWildcards = True
            .Wrap = wdFindStop
            .Format = False
            .Forward = True
            'execute the replace
            .Execute Replace:=wdReplaceAll
        End With
        
        ' Remove white space at the beginning of lines

    With Selection.Find

        .Text = "^p^w"

        .Replacement.Text = "^p"

    End With

Selection.Find.Execute Replace:=wdReplaceAll

' Removes spaces in first line

    With Selection.Find

        .Text = " {3,}"

        .Replacement.Text = ""

    End With

Selection.Find.Execute Replace:=wdReplaceAll
         
        With .Find
            'This time its looking for excessive spaces after a paragraph mark
            .Text = "^p "
            'What to replace it with
            .Replacement.Text = "^p"
            .MatchWildcards = False
            .Wrap = wdFindStop
            .Format = False
            .Forward = True
            'Execute the replace
            .Execute Replace:=wdReplaceAll
        End With
    End With
ERRORHANDLER:
    With Selection
        .ExtendMode = False
        .HomeKey Unit:=wdStory
    End With

End Sub

1. Функция replace не сможет перехватить страницу, пока это происходит. Имейте в виду, что разбивка на страницы в Word, как правило, скользкая вещь. См. Word не знает, что такое Страница, Дайя Митчелл wordmvp.com/Mac/PagesInWord.html — Я бы сначала перехватил номера страниц, на которых появляется найденный объект, сохранил эту информацию, а затем выполнил замену. — Что вы сделали для создания документа отчета? Я бы подошел к этому, создав массив для хранения термина и номера страницы, а затем экспортировал его в новый документ, а не перелистывал туда и обратно.

2. Спасибо за совет! Я думаю, именно поэтому существует не так много примеров подобных макросов. Я поиграю с этим. Я, вероятно, попытаюсь использовать скрипт, чтобы открыть новую пустую страницу в конце макроса и распечатать там массив, когда я смогу понять, как получить информацию.

3. Напротив, в Интернете много таких макросов. Примеры макросов, использующих F / R для извлечения страниц # для указанного содержимого, см.: msofficeforums.com/140662-post2.html ; и msofficeforums.com/149178-post3.html . Для ваших целей, однако, было бы лучше выполнить F / R с включенным отслеживанием изменений. Затем у вас есть возможность сгенерировать отчет об изменениях, используя либо исходную разбивку на страницы, либо исправленную разбивку на страницы. Смотрите, например: msofficeforums.com/133132-post2.html

4. Отлично, я изучу это.

Ответ №1:

Вы не можете использовать replaceAll, потому что это не позволит сделать паузу для записи номера страницы замены, я изменил ваш код на повторяющийся поиск / замену. Я также изменил его, чтобы использовать диапазон по сравнению с выбором, потому что это уменьшит часть потерянной скорости, перейдя от replaceAll к методу итерации. И, наконец, я добавил запись номеров разделов и страниц в текстовый файл, который будет создан в той же папке, что и документ.

Проверьте его и измените в соответствии с вашими потребностями.

 Sub SpacingFixer()
    Dim doc As Word.Document, rng As Word.Range
    Dim FileNum As Integer
    Dim oFile As String
    
    On Error GoTo ERRORHANDLER
    Set doc = ActiveDocument
    Set rng = doc.Content
    
    FileNum = FreeFile()
    oFile = doc.path amp; "AuthorTec_Edits.txt"
    If Dir(oFile, vbNormal) <> vbNullString Then
        Kill oFile
    End If
    Open oFile For Append As #FileNum
    Print #FileNum, "Extra spaces between words on Section:Page:"
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        'Here is where it is actually looking for spaces between words
        .Text = " [ ]@([! ])"
        'This line tells it to replace the excessive spaces with one space
        .Replacement.Text = " 1"
        .MatchWildcards = True
        .Wrap = wdFindStop
        .Format = False
        .Forward = True
        'execute the replace
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) amp; ":" amp; rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
        
        ' Remove white space at the beginning of lines
    Print #FileNum, "Extra white space at beginning of lines on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .Text = "^p^w"
        .Replacement.Text = "^p"
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) amp; ":" amp; rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With

' Removes spaces in first line
    Print #FileNum, "Removed spaces in first line on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .Text = " {3,}"
        .Replacement.Text = ""
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) amp; ":" amp; rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With

    Print #FileNum, "Removed excessive spaces after a paragraph mark on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        'This time its looking for excessive spaces after a paragraph mark
        .Text = "^p "
        'What to replace it with
        .Replacement.Text = "^p"
        .MatchWildcards = False
        .Wrap = wdFindStop
        .Format = False
        .Forward = True
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) amp; ":" amp; rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
ERRORHANDLER:
    If Err.Number <> 0 Then
        MsgBox Err.Number amp; vbCr amp; Err.Description, vbCritical
        Err.Clear
    Else
        MsgBox "Action Complete"
    End If
    If FileNum <> 0 Then Close #FileNum

End Sub

1. Спасибо! Я поиграю и опубликую то, что я создаю, здесь для других.

2. Это на самом деле делает все, что я мог попросить, и может быть изменено для поддержки других типов функций поиска и замены! Каждому, кто изучает макросы, есть чему поучиться из этого кода!

Ответ №2:

Добавлена возможность определять стили маркеров 1 и 2, заканчивающиеся точками, и печатать их в текстовом файле.

Также обнаружено, что если вы создаете бесконечный цикл, это потому, что .Перенос должен быть = wdFindStop

 .Wrap = wdFindStop

 
Sub Spacingandbulletfixerwithreport()
    Dim doc As Word.Document, rng As Word.Range
    Dim FileNum As Integer
    Dim oFile As String
    
    On Error GoTo ERRORHANDLER
    Set doc = ActiveDocument
    Set rng = doc.Content
    
    FileNum = FreeFile()
    oFile = doc.Path amp; "AuthorTec_Edits.txt"
    If Dir(oFile, vbNormal) <> vbNullString Then
        Kill oFile
    End If
    Open oFile For Append As #FileNum
    Print #FileNum, "Extra spaces between words on Section:Page:"
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        'Here is where it is actually looking for spaces between words
        .Text = " [ ]@([! ])"
        'This line tells it to replace the excessive spaces with one space
        .Replacement.Text = " 1"
        .MatchWildcards = True
        .Wrap = wdFindStop
        .Format = False
        .Forward = True
        'execute the replace
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) amp; ":" amp; rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
        
        ' Remove white space at the beginning of lines
    Print #FileNum, "Extra white space at beginning of lines on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .Text = "^p^w"
        .Replacement.Text = "^p"
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) amp; ":" amp; rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With

' Removes spaces in first line
    Print #FileNum, "Removed spaces in first line on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .Text = " {3,}"
        .Replacement.Text = ""
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) amp; ":" amp; rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With

    Print #FileNum, "Removed excessive spaces after a paragraph mark on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        'This time its looking for excessive spaces after a paragraph mark
        .Text = "^p "
        'What to replace it with
        .Replacement.Text = "^p"
        .MatchWildcards = False
        .Wrap = wdFindStop
        .Format = False
        .Forward = True
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) amp; ":" amp; rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
    
    'search for bullet1s with full stops
    Print #FileNum, "Removed Bullet 1s on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Style = ActiveDocument.Styles("Bullet 1")
        .Replacement.ClearFormatting
        .Text = ".^p"
        .Replacement.Text = ".^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) amp; ":" amp; rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
           Wend
        End With
           
               'search for bullet2s with full stops
    Print #FileNum, "Removed Bullet 2s on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Style = ActiveDocument.Styles("Bullet 2")
        .Replacement.ClearFormatting
        .Text = ".^p"
        .Replacement.Text = ".^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) amp; ":" amp; rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
    
    

ERRORHANDLER:
    If Err.Number <> 0 Then
        MsgBox Err.Number amp; vbCr amp; Err.Description, vbCritical
        Err.Clear
    Else
        MsgBox "Action Complete"
    End If
    If FileNum <> 0 Then Close #FileNum

End Sub

Метки: Скопируйте все замены сделанные в макросе в отдельный файл в виде отчета с номером страницы