将方括号+内容替换为合并字段

Question

我正在尝试将方括号的内容更改为合并字段。我有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 " & fileName & " " & startStr & " " & 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 & "\" & fFolder
    objDoc.Close
    objWord.Quit

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

End Function

请努力理解单词中的对象是如何原谅的。

对于引起此问题的原因的任何答案将不胜感激，或者以更好的方式帮助实现此方法的任何帮助。

Answer 1

尝试：

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 & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & 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 " & .Text, Preserveformatting:=False
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
End Sub

上面的代码处理选定文件夹中的所有文档。

Answer 2

好。通用建议是始终始终将选项作为模块或类的开始。这有助于突出显示与代码滥用有关的语法错误和未声明的变量等。在已发布的代码中，存在一个未声明的变量“文件名”。

使用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 " & Filename & " " & startStr & " " & 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 & "\" & fFolder
    objDoc.Close
    objWord.Quit

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

End Sub

上面的代码编译没有错误，但是我没有测试逻辑。我将其保留为“读者练习”