Блог

Я пытаюсь изменить содержимое квадратных скобок на поле слияния. Мне нужно просмотреть 80 документов, некоторые из которых не содержат квадратных скобок, а некоторые содержат несколько (ни одного вложенного).

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

 Public Function searchFiles(fFile As Variant, rootFolderStr2 As String, rootFolderStr As String)
    Dim strTemp As String, mfc As String, msg As String
    Dim startStr As Integer, endStr As Integer
    Dim objWord As New Word.Application
    Dim objDoc As Word.Document
    Dim aField As Field, fFolder As String
    Dim rng As Variant, myField As Field, oldField As Variant

    On Error GoTo ErrorHandler

    'open file
    'Open fFile For Input As #1
    Set objDoc = objWord.Documents.Open(fFile)
    objDoc.TrackRevisions = False
    strTemp = objDoc.Range(0, objDoc.Range.End)

    startStr = InStrRev(strTemp, "[")
    endStr = InStrRev(strTemp, "]")

    Do While startStr <> 0
        'Merge field contents
        mfc = Right(Left(strTemp, endStr - 1), endStr - startStr - 1)
        Set rng = objDoc.Range(startStr - 1, endStr)
        Set myField = objDoc.Fields.Add(Range:=rng, Type:=wdFieldMergeField, Text:=mfc)

        strTemp = objDoc.Range(0, objDoc.Range.End)

        'Find next merge field
        startStr = InStrRev(strTemp, "[")
        endStr = InStrRev(strTemp, "]")
        If endStr < startStr And endStr <> -1 Then
            msg = "Error occured in " amp; fileName amp; " " amp; startStr amp; " " amp; endStr
            Debug.Print (msg)
            startStr = 0
            endStr = 0
        End If
    Loop
    'put in right folder
    fFolder = Right(objDoc.FullName, Len(objDoc.FullName) - Len(rootFolderStr))

    objDoc.SaveAs fileName:=rootFolderStr2 amp; "" amp; fFolder
    objDoc.Close
    objWord.Quit

ErrorHandler:
If Err.Number <> 0 Then
    Debug.Print ("Error occured in file: " amp; fileName amp; " " amp; Err.Description)
    Exit Function
End If

End Function
  

Я изо всех сил пытаюсь понять, как работают объекты в word, так что простите, пожалуйста.

Любые ответы относительно того, что вызывает эту проблему, были бы оценены или любая помощь с методами, позволяющими сделать это лучше.

Попробуйте:

 Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder amp; "*.doc", vbNormal)
While strFile <> ""
  If strFolder amp; "" amp; strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder amp; "" amp; strFile, AddToRecentFiles:=False, Visible:=False)
      Call MakeFields(wdDoc)
      wdDoc.Close SaveChanges:=True
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Sub MakeFields(wdDoc As Document)
With wdDoc.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Format = False
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "[*]"
    .Execute
  End With
  Do While .Find.Found
    .Characters.First.Text = vbNullString
    .Characters.Last.Text = vbNullString
    .Fields.Add Range:=.Duplicate, Type:=wdFieldEmpty, Text:="MERGEFIELD " amp; .Text, Preserveformatting:=False
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
End Sub
  

Приведенный выше код обрабатывает все документы в выбранной папке.

ОК. Общий совет заключается в том, чтобы всегда, всегда, всегда указывать option явно в качестве начала вашего модуля или класса. Это помогает выявить ошибки в вашем коде, связанные с неправильным использованием синтаксиса и необъявленных переменных и т.д. В вашем опубликованном коде есть одна необъявленная переменная ‘Filename’.

При работе с Word всегда лучше попытаться найти способ работы с объектной моделью word, а не извлекать текст.

Вы можете изменить существующий код, заменив instrrev методами .moveStart / EndUntil.

Я обновил ваш код, чтобы использовать эти методы перемещения.

Если вы не понимаете, что делает ключевое слово, наведите на него курсор и нажмите F1. Это приведет вас на страницу справки MS. Для объектной модели Word страницы справки требуют тщательного чтения.

 Option Explicit

' Changed to sub as you are not returning any values
Public Sub searchFiles(fFile As Variant, rootFolderStr2 As String, rootFolderStr As String)

Const FieldOpen                     As String = "["
Const FieldClose                    As String = "]"

    Dim strTemp As String, mfc As String, msg As String

    Dim objWord As New Word.Application
    Dim objDoc As Word.Document
    ' Dim aField As FieldDim
    Dim fFolder As String
    ' Dim rng As Variant
    ' Dim myField As Field
    ' Dim oldField As Variant

    ' Not previously declared
    Dim Filename As String


    Dim SearchRng                   As Word.Range
    Dim FieldRng                    As Word.Range
    Dim Moved                       As Long
    'open file
    'Open fFile For Input As #1
    On Error GoTo ErrorHandler
    Set objDoc = objWord.Documents.Open(fFile)
    objDoc.TrackRevisions = False

    'strTemp = objDoc.Range(0, objDoc.Range.End)
    Set SearchRng = ActiveDocument.Content

    'startStr = InStrRev(strTemp, "[")
    Moved = SearchRng.MoveStartUntil(cset:=FieldOpen)

    'Do While startStr <> 0
    Do Until Moved = 0
        'Merge field contents
        'mfc = Right(Left(strTemp, endStr - 1), endStr - startStr - 1)
        FieldRng.Start = SearchRng.Start   1

        'endStr = InStrRev(strTemp, "]")
        ' exit if we don't find a closing field marker
        ' The side effect (which we want) is that the end is also moved
        If SearchRng.MoveEndUntil(cset:=FieldClose) = 0 Then GoTo ErrorHandler
        FieldRng.End = SearchRng.End   1

        ' reduce the FieldRng to just the text
        FieldRng.Characters.First.Delete
        FieldRng.Characters.Last.Delete

        'Set rng = objDoc.Range(startStr - 1, endStr
        'Set myField = objDoc.Fields.Add(Range:=rng, Type:=wdFieldMergeField, Text:=mfc)
        objDoc.Fields.Add Range:=FieldRng, Type:=wdFieldMergeField, Text:=FieldRng.Text

        'strTemp = objDoc.Range(0, objDoc.Range.End)
        ' We now need to move the start of the search range to after the mergefield
        SearchRng.Start = FieldRng.End   1

        'Find next merge field
        'startStr = InStrRev(strTemp, "[")
        'endStr = InStrRev(strTemp, "]")
        Moved = SearchRng.MoveStartUntil(cset:=FieldOpen)
'        If endStr < startStr And endStr <> -1 Then
'            msg = "Error occured in " amp; Filename amp; " " amp; startStr amp; " " amp; endStr
'            Debug.Print (msg)
'            startStr = 0
'            endStr = 0
'        End If
    Loop
    'put in right folder
    fFolder = Right(objDoc.FullName, Len(objDoc.FullName) - Len(rootFolderStr))

    objDoc.SaveAs Filename:=rootFolderStr2 amp; "" amp; fFolder
    objDoc.Close
    objWord.Quit

ErrorHandler:
If Err.Number <> 0 Then
    Debug.Print ("Error occured in file: " amp; Filename amp; " " amp; Err.Description)
    Exit Sub
End If

End Sub
  

Приведенный выше код компилируется без ошибок, но я не тестировал логику. Я оставлю это как «упражнение для читателя»