I am trying to figure out how to highlight bracketed text in a word document but it has nested brackets. I could loop through the entire document character by character tracking bracket opening and closing but this is not efficient in large document. I would like to highlight the nested brackets a different color.
[some text highlighted yellow[something else highlighted green] some more text highlighted yellow [another item highlighted Green] and then the rest highlighted yellow]
I was using this originally (vb.net) until I ran across the nested brackets which is when it breaks down:
'Toggles the highlighting of brackets in the document off and on
'Get Active document
Dim wdDoc As Word.Document
wdDoc = wdApp.ActiveDocument
'Set highlight color to yellow
wdApp.Options.DefaultHighlightColorIndex = Word.WdColorIndex.wdYellow
'Search for text between brackets and highlight text
With wdDoc.Content.Find
.ClearFormatting()
.Text = "\[*\]"
With .Replacement
.Text = ""
.ClearFormatting()
.Highlight = TogBtnBrackets.Checked
End With
.Forward = True
.Wrap = Word.WdFindWrap.wdFindContinue
.Format = True
.MatchWildcards = True
.Execute(Replace:=Word.WdReplace.wdReplaceAll)
End With
'Finished set wdDoc to nothing
wdDoc = Nothing
Dim Tog As String = ""
If TogBtnBrackets.Checked = True Then
Tog = "Highlighted"
TogBtnBrackets.Label = "Bracket Highlighting - On "
Else
Tog = "un-Highlighted"
TogBtnBrackets.Label = "Bracket Highlighting - Off"
End If
I have found a few things talking about using RegEx but I am really unfamiliar with them and cannot seem to wrap my head around them. It also seems that you have to know the number of "nest" levels to write the correct regex anyway and I will not always know that.
With Word you do not want RegEx because that won't respect or allow formatting. Word's wildcard function is similar, but not the same...
Since it's simpler to test I've done this for you in VBA. You'll need to make some small changes (adding wdAppp
where necessary, for example) to run it in VB.NET.
Since it's necessary to test whether the start and end bracket pair contain additional start brackets, it's not possible to use Replace
. After each successful "Find", therefore, the code tests for the presence of opening brackets. Since there will always be one instance, the test is performed in a loop.
The test uses Instr
to get the position of the opening bracket. For the second and any following instances the Start
position of the Range
is set to the instance of the opening bracket. Once no more are found, highlighting is applied, the Range is collapsed and the Find
is executed again in the loop.
I put the test in a separate function making it possible to 1) test any character (squiggly brackets or parentheses, for example) and 2) return the number of instances, in case this would be of any interest.
Sub FindSquareBracketPairs()
Dim rngFind As Word.Range
Dim sOpen As String, sClose As String
Dim sFindTerm As String
Dim bFound As Boolean, lPosOpen As Long
Set rngFind = ActiveDocument.content
sOpen = "["
sClose = "]"
sFindTerm = "\[*\]"
With rngFind.Find
.ClearFormatting
.text = "\[*\]"
.Forward = True
.wrap = Word.WdFindWrap.wdFindStop
.MatchWildcards = True
bFound = .Execute
Do While bFound
lPosOpen = NumberOfCharInRange(rngFind, sOpen)
rngFind.HighlightColorIndex = Word.WdColorIndex.wdYellow
rngFind.Collapse wdCollapseEnd
bFound = .Execute
Loop
End With
End Sub
'Checks whether there's more than one instance of searchTerm in the rng.Text
'For each instance above one, move the Start point of the range
'To the position of that instance until no more are "found".
'Since the Range is passed ByRef this will change the original
'range's position in the calling procedure.
Function NumberOfCharInRange(ByRef rng As Word.Range, _
ByRef searchTerm As String) As Long
Dim lCountChars As Long, lCharPos As Long
Dim s As String
s = rng.text
Do
lCharPos = InStr(s, searchTerm)
If lCharPos > 1 Then
lCountChars = lCountChars + 1
rng.Start = rng.Start + lCharPos
End If
s = Mid(s, lCharPos + 1)
Loop Until lCharPos = 0
NumberOfCharInRange = lCountChars
End Function
Thank you Cindy Meister your code was a great place for me to start to get unstuck. It worked great for getting the the brackets that were nested but would not highlight the outer bracketed information. I finally came up with a solution in VBA code that I'l move over to VB.NET later.
Option Base 1
Sub HighlightNestedBrackets()
Dim Ary() As Variant
Dim cntr As Integer
Dim NumberOpenBrackets As Integer
Dim i As Integer
Dim OpenBracket As String
Dim CloseBracket As String
ReDim Ary(2, 1)
cntr = 1
'Change to [], or (), or {}, etc. as needed
OpenBracket = "\["
CloseBracket = "\]"
'Find opening brackets and store in array
Call FindOpenCloseBracket(Ary, cntr, ActiveDocument.Content, OpenBracket, True)
'Check number of open brackers
NumberOpenBrackets = UBound(Ary, 2)
'Find closing brackets and store in array
Call FindOpenCloseBracket(Ary, cntr, ActiveDocument.Content, CloseBracket, False)
'Check balanced number of open close Brackets
If NumberOpenBrackets <> UBound(Ary, 2) / 2 Then
MsgBox "Unbalanced Open Close Bracket Pairs", vbExclamation, "Error"
Exit Sub
End If
'Sort the array by bracket position
Call BubbleSort(Ary, 1)
'Set each bracket pair
Dim PairAry() As Variant
ReDim PairAry(1)
Dim FP As Boolean 'First pass variable
FP = True
For i = LBound(Ary, 2) To UBound(Ary, 2)
If FP = True Then 'on first pass place first bracket number in array
PairAry(1) = Ary(2, i)
FP = False
Else
If Ary(2, i) <> 0 Then 'if it is not a closing bracket redim the array and place the bracket number in the bottom of the array
ReDim Preserve PairAry(UBound(PairAry) + 1)
PairAry(UBound(PairAry)) = Ary(2, i)
Else 'if it is a closing bracket then the last bracket number is the placed in the pair array is the associated opening bracket
Ary(2, i) = PairAry(UBound(PairAry))
If UBound(PairAry) <> 1 Then 'can't redim under lower bound
'remove the last used opening bracket number
ReDim Preserve PairAry(UBound(PairAry) - 1)
End If
End If
End If
Next i
'sort array again by the bracket pair column this time to get pairs together
Call BubbleSort(Ary, 2)
'loop through each pair and highlight as needed
For i = LBound(Ary, 2) To UBound(Ary, 2) Step 2 'step by 2 since pairs
'you coule use an elseif here if you know the number of nested layers I should only have 2 layers in mine so I only needed else
If Ary(1, i) > Ary(1, i + 1) Then 'bubble sort doesnt always get pairs character position first last correct so you need to check
'If already highlighted yellow then highlight green
If ActiveDocument.Range(Ary(1, i + 1), Ary(1, i) + 1).HighlightColorIndex = wdYellow Then
ActiveDocument.Range(Ary(1, i + 1), Ary(1, i) + 1).HighlightColorIndex = wdBrightGreen
Else
ActiveDocument.Range(Ary(1, i + 1), Ary(1, i) + 1).HighlightColorIndex = wdYellow
End If
Else
'If already highlighted yellow then highlight green
If ActiveDocument.Range(Ary(1, i), Ary(1, i + 1) + 1).HighlightColorIndex = wdYellow Then
ActiveDocument.Range(Ary(1, i), Ary(1, i + 1) + 1).HighlightColorIndex = wdBrightGreen
Else
ActiveDocument.Range(Ary(1, i), Ary(1, i + 1) + 1).HighlightColorIndex = wdYellow
End If
End If
Next i
End Sub
'------------------------------------------------------------------------------------------------------------------------
Sub FindOpenCloseBracket(ByRef Ary() As Variant, ByRef cntr As Integer, ByVal oRng As Range, ByVal TextToFind As String, OpenBracket As Boolean)
With oRng.Find
.ClearFormatting
.Text = TextToFind '"\["
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
Do While .Execute
With oRng
ReDim Preserve Ary(2, cntr)
Ary(1, cntr) = oRng.Start 'save barcket position in array
If OpenBracket = True Then
Ary(2, cntr) = cntr 'save opening bracket number
Else
Ary(2, cntr) = 0 'place 0 in array to indicate closing bracket
End If
'Debug.Print oRng.Start & " - " & Cntr
cntr = cntr + 1
End With
Loop
End With
End Sub
'------------------------------------------------------------------------------------------------------------------------
Sub BubbleSort(ByRef Ary() As Variant, Col As Long)
'Sorts an array using bubble sort algorithm
Dim First As Integer, Last As Long
Dim i As Long, j As Long
Dim Temp1 As Integer
Dim Temp2 As Integer
First = LBound(Ary, 2)
Last = UBound(Ary, 2)
For i = First To Last - 1
For j = i + 1 To Last
If Ary(Col, i) > Ary(Col, j) Then
Temp1 = Ary(1, j)
Temp2 = Ary(2, j)
Ary(1, j) = Ary(1, i)
Ary(2, j) = Ary(2, i)
Ary(1, i) = Temp1
Ary(2, i) = Temp2
End If
Next j
Next i
End Sub
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.