Hightlight All Instances Of A Word In Richtextbox 2

[Hackster]

I've managed to put together the code to find and hightlight a word in a richtextbox, but it will only do it once. I need to find, and highlight, all instances of the word, and I'm getting nowhere fast. What modifications do I need to make to this?

Dim strWord As String
Dim lPos As Long

strWord = "Hello"

lPos = InStr(1, RichTextBox1.Text, strWord, vbTextCompare)

If lPos > 0 Then
    With RichTextBox1
       .SelStart = lPos - 1
       .SelLength = Len(strWord)
       .SelColor = vbRed
       .SelBold = True
       .SelStart = Len(RichTextBox1.Text)
    End With
End If

 

[HarleyQuinn]

How about something like:

Private Sub Command1_Click()
Dim strWord As String
Dim lPos As Long

strWord = "Hello"

lPos = InStr(1, RichTextBox1.Text, strWord, vbTextCompare)

Do Until lPos = 0

    With RichTextBox1
       .SelStart = lPos - 1
       .SelLength = Len(strWord)
       .SelColor = vbRed
       .SelBold = True
       .SelStart = Len(RichTextBox1.Text)
    End With


lPos = InStr([red]lPos - 1 + Len(strWord)[/red], RichTextBox1.Text, strWord, vbTextCompare)

Loop

End Sub

The part highlighted in [red]red[/red] means that the InStr will start from the end of the last found occurance of strWord.

Hope this helps

HarleyQuinn
---------------------------------
Get the most out of Tek-Tips, read FAQ222-2244 before posting.

 

[HarleyQuinn]

Just tested my code again and if you are looking for 1 letter and an occurance of that letter is the first character in the richtextbox it sets itself into an infinite loop. To get around that replace the line:

lPos = InStr([red]lPos - 1 + Len(strWord)[/red], RichTextBox1.Text, strWord, vbTextCompare)

with the line:

lPos = InStr([red]lPos + Len(strWord)[/red], RichTextBox1.Text, strWord, vbTextCompare)

Hope this helps

HarleyQuinn
---------------------------------
Get the most out of Tek-Tips, read FAQ222-2244 before posting.

 

[strongm]

Might I suggest a look at thread222-148743 (which, if nothing else, demonstrates that I've been pushing RegEx solutions on this forum for a fair while ... )

Mind you I may have a new solution to this problem, but it'll have to wait ...

 

[HarleyQuinn]

Might I suggest a look at thread222-148743 (which, if nothing else, demonstrates that I've been pushing RegEx solutions on this forum for a fair while ... )

Looking forward to seeing your possible new solution.

HarleyQuinn
---------------------------------
Get the most out of Tek-Tips, read FAQ222-2244 before posting.

 

[Hypetia]

The beauty of Regular Expressions is that it finds ALL the instances in a single method call (the Execute method). You only need to examine these instances and apply desired formatting to richtextbox.

Add a reference to Regular Expressions library and try this code.
___
[tt]
Private Sub Command1_Click()
Dim re As RegExp, objMatch As Match
Set re = New RegExp
re.Global = True
re.IgnoreCase = True 'if desired
re.Pattern = "Hello"
For Each objMatch In re.Execute(RichTextBox1.Text)
With RichTextBox1
.SelStart = objMatch.FirstIndex
.SelLength = objMatch.Length
.SelColor = vbRed
.SelBold = True
End With
Next
End Sub[/tt]

 

[strongm]

Or you can be more cunning with a replacement string, as I was in the referenced thread, in order to avoid having to do the For Each ...

 

[strongm]

Ok, I do have an alternative solution - but I may have gone a little overboard on it ... but what the heck, it illustrates a number of things so here we go.

Create a new project. Add a reference to VbScript Regular Expressions, and to "tom" (if this does not appear in your list of references, use the browse button to find riched20.dll).

Now add a class module (Class1), and drop in the following code:

[blue]Option Explicit

Private tomDoc As ITextDocument
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_USER = &H400&
Private Const EM_GETOLEINTERFACE = (WM_USER + 60)
Private mvarForeHighlight As Long
Private mvarBackHighlight As Long
Private mvarEnbold As Boolean

Public Property Let Bold(ByVal vData As Boolean)
    mvarEnbold = vData
End Property

Public Property Get Bold() As Boolean
    Enbold = mvarEnbold
End Property

Public Property Let BackHighlight(ByVal vData As Long)
    mvarBackHighlight = vData
End Property

Public Property Get BackHighlight() As Long
    BackHighlight = mvarBackHighlight
End Property

Public Property Let ForeHighlight(ByVal vData As Long)
    mvarForeHighlight = vData
End Property

Public Property Get ForeHighlight() As Long
    ForeHighlight = mvarForeHighlight
End Property

Public Property Set TargetRTB(ByVal vData As RichTextBox)
    Dim myIUnknown As Object
    SendMessage vData.hwnd, EM_GETOLEINTERFACE, 0&, myIUnknown
    Set tomDoc = myIUnknown
End Property

' function template:
' replaceFunc(matchedString [, subMatch1 [, ...]] , matchPos, source)
' Make this the default procedure for the class
Public Function CustomFunction(ParamArray a()) As String
    tomDoc.Selection.Start = a(1)
    tomDoc.Selection.End = a(1) + Len(a(0))
    tomDoc.Selection.Font.Bold = mvarEnbold
    tomDoc.Selection.Font.ForeColor = mvarForeHighlight
    tomDoc.Selection.Font.BackColor = mvarBackHighlight
    CustomFunction = a(1)
End Function

Private Sub Class_Terminate()
    Set tomDoc = Nothing
End Sub[/blue]

Use Tools/Procedure Attributes to make 'CustomFunction' the default procedure for the class
Now add a richtextbox and a command button to a form, and drop in this code:

[blue]Option Explicit

Public Sub RTBWordHighLight(RTB As RichTextBox, strHighlightText As String, Optional BackHighlight As Long = vbRed, Optional ForeHighlight As Long = vbYellow, Optional Bold As Boolean = True)
    Dim myHighlighter As Class1
    
    Set myHighlighter = New Class1
    
    With myHighlighter
        Set .TargetRTB = RTB
        .BackHighlight = BackHighlight
        .ForeHighlight = ForeHighlight
        .Bold = Bold
    End With
    
    With New RegExp
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = "\b" & strHighlightText & "\b"
        .Replace RTB.Text, myHighlighter
    End With

    Set myHighlighter = Nothing
End Sub

Private Sub Command1_Click()
    RTBWordHighLight RichTextBox1, "text"
End Sub

Private Sub Form_Load()
    RichTextBox1.Text = "Just a short bit of example text with which we will demonstrate text highlighting"
End Sub[/blue]

 

[vbSun]

If you just want to make it bold,

RichTextBox1.TextRTF = Replace(RichTextBox1.TextRTF, strToLook, "\b " & strToLook & " \b0")

------------------------------------------
The faulty interface lies between the chair and the keyboard.

 

[vbSun]

Bold and Italic...

RichTextBox1.TextRTF = Replace(RichTextBox1.TextRTF, strToLook, "\b\i " & strToLook & " \b0\i0")

------------------------------------------
The faulty interface lies between the chair and the keyboard.

 

[strongm]

Was any of this of any use, Hackster?

 

[rkasnick]

I can't answer for Hackster, but as far as i am concerned, HarleyQuinn gets as many stars as possible. His/her solution was EXACTLY what I was looking for, I have an app that uses multiple search terms to build a SQL string and return data to a richtextfield, and I have been trying to perfect the highlighting of multiple search terms, adding that code into the loop worked amazingly fast and accurately. THANK YOU.

 

[strongm]

I'm glad someone benefited

(Mind you, it's probably the slowest of the various solutions given here once the number of required replacements begins to grow)

 

[HarleyQuinn]

rkasnick - Thank you, I'm glad we could all help. To save you typing both gender's in future, I'm a him

strongm - Agreed, mine probably is the slowest of the solutions, but it's not a bad solution for starting off with the understandings of where and when to implement loops in code if you don't want to completely rewrite the process .

strongm and Hypetia - I don't use a lot of Reg Exp (by that I mean none) but will start looking into them after your solutions (and several other of your Reg Exp posts) got me wondering. Thanks for always having a Reg Exp solution if one can be found , have stars on me.

Cheers

HarleyQuinn
---------------------------------
Get the most out of Tek-Tips, read FAQ222-2244 before posting.

 

[strongm]

>mine probably is the slowest of the solutions

Actually it's the fastest if there are only a few substitions to be made. It is as the number goes up that it gets slower.

 

[HarleyQuinn]

Sorry, forgot to point out I was refering to your comment about it being the slowest as the number of replacements grows

HarleyQuinn
---------------------------------
Get the most out of Tek-Tips, read FAQ222-2244 before posting.

 

[strongm]

S'ok. I guess we're saying the same thing.

The nice thing is that the original poster now has a number of solutions, each of which may suit different scenarios.

 

[HarleyQuinn]

strongm - Agreed

HarleyQuinn
---------------------------------
Get the most out of Tek-Tips, read FAQ222-2244 before posting.

 

[Hackster]

Well, I am overwhelmed with the responses to this, and yes, each and every example has been useful.

Thanks to one and all.