Finding text in a rectangle

[Bakuryu]

Hi, I was wondering if there was a way to find text in rectangles.
I got a big hierarchy with lots of rectangles with names in it and it would be very usefull if i could search for names.

Thanks in advance

 

[Damon Ostrander]

Search for text in rectangles

Hi Bakuryu,

Give this code a try:

Dim FindTxtSave As String 'Last rectangle search text

Sub FindRecText()
FindRectangleText
End Sub

Sub FindRectangleText(Optional FindTxt As String = "")
'Searches all rectangles on the active sheet for text
Dim Sh As Shape
Dim iCh As Integer
Dim lCh As Integer
Dim answer As Variant
Dim FillSet As Boolean

If FindTxt = "" Then
FindTxt = InputBox("Enter find text", "Rectangle Text Search")
End If
If FindTxt = "" Then Exit Sub
lCh = Len(FindTxt)

For Each Sh In ActiveSheet.Shapes
If Sh.Type = msoTextBox Then
iCh = 1
FillSet = False
Do While True
iCh = InStr(iCh, Sh.TextFrame.Characters.Text, FindTxt)
If iCh = 0 Then Exit Do
If Not FillSet Then
Sh.Fill.ForeColor.RGB = NotRGB(Sh.Fill.ForeColor.RGB)
FillSet = True
End If
Beep
'highlight characters
With Sh.TextFrame.Characters(iCh, lCh)
.Font.Color = NotC(.Font.Color)
End With
iCh = iCh + 1
Loop
End If
Next Sh

FindTxtSave = FindTxt

End Sub

Sub ClearFind()
FindRectangleText FindTxtSave
End Sub

Function NotC(Cin As Variant) As Long
'Invert colorindex color and convert to RGB
If Cin = 0 Or Cin = Null Then
NotC = &HFFFFFF
Else
NotC = Not ActiveWorkbook.Colors(Cin)
NotC = NotC And &HFFFFFF
End If
End Function

Function NotRGB(Cin As Long) As Long
'Invert RGB color
NotRGB = Not Cin
NotRGB = NotRGB And &HFFFFFF
End Function

This code should be placed in a standard macro module. To do this, go to the VBE (keyboard Alt-TMV), insert a new macro module (Alt-IM), and paste this code into the Code pane.

The approach I used was to highlight all the text found. To do the find, run macro FindRecText. It will prompt you for the text you want to search for and will highlight the found text by reversing the color of the text--and to make sure it is visible it also reverses the fill color of the rectangles. Obviously, reversing black text to white in a rectangle containing white fill would make the text invisible--not a very effective way to highlight it. But reversing both text and fill ensures the found text is visible, even though it might make the other text invisible.

To un-highlight the previously found text, run the macro ClearFind.

I hope this does what you want.

Damon

 

[Bakuryu]

Hey Damon,

Thanks alot for replying.

In your code you used If Sh.Type = msoTextBox Then

But we're using Rectangles not textboxes.. do you know the Sh.Type name for rectangles?

Thanks in advance

 

[Andrew Poulsom]

If it's an Autoshape its type will be msoAutoShape and its AutoShapeType will be msoShapeRectangle if it's a rectangle.

Sub Test()
    Dim Sh As Shape
    For Each Sh In ActiveSheet.Shapes
        If Sh.Type = msoAutoShape Then
             If Sh.AutoShapeType = msoShapeRectangle Then
                MsgBox "Rectangle"
             End If
        End If
    Next Sh
End Sub

 

[Damon Ostrander]

Hi again Bakuryu,

Were you able to incorporate Andrew's answer into my code? Let us know if any problems.

Damon


Thank you Andrew for helping out.

 

[Bakuryu]

Yes, it worked! Thanks alot guys.

Its almost perfect.. the only things needed extra is that it jumps to the highlighted box and not make it case-sensitive.. is that possible?

Thanks alot again your help is really appreciated!

 

[Damon Ostrander]

Hi Bakuryu,

To make my search code case-insensitive, change

iCh = InStr(iCh, Sh.TextFrame.Characters.Text, FindTxt)

to

iCh = InStr(iCh, UCase(Sh.TextFrame.Characters.Text), UCase(FindTxt))

Regarding having the search find one occurrence at a time, it should be possible for the code to do this. Bit I don't believe it is possible with VBA to select text or place the cursor within a textbox, even though it can read and write the text. So if your intent is to have it work like a Find in MS Word, such that text found in textboxes is highlighted and selected, I think you are out of luck.