Replace square brackets + contents with the contents as a mergefield - vba

Question

I am trying to change the contents of square brackets into a merge field. I've got 80-ish documents to go through some with none square brackets and some with a few (none nested).
I have managed to run my code and it has worked for some files. Others (majority) have given an overflow error. When I examined what was happening in one of the files, the code picks up the contents correctly, it just puts the merge field in the wrong place which in turn causes it to keep finding the same set of square brackets.
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
I'm struggling to understand how the objects in word work so forgive, please.
Any answers as to what's causing this problem would be appreciated or any help with methods to do this in a better manner.

Answer 1

Try:
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
The above code processes all documents in the selected folder.

Answer 2

OK. The generic advice is to always, always, always put option explicit as the start of your module or class. This helps highlights errors in your code related misuse of syntax and undeclared variables etc. In your posted code there is one undeclared variable 'Filename'.
When working with Word it is always better to try to find a way of working with the word object model rather than extracting text.
You can modify your existing code by replacing the instrrev with the .MoveStart/EndUntil methods.
I've updated your code to use these move methods.
If you don't understand what a keyword does then place your cursor on it and press F1. This will take you to the MS help page. For the Word object model the help pages need careful reading.
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
The code above compiles without error but I haven't testing the logic. I'll leave that as 'an exercise for the reader'