Toggle Red Highlight in Text boxes and in Tables

[bcummins77]

Hi all,

I have created the following macro to toggle on/off red highlight for selected text whether in a text box or table. For the table there doesn't have to be text for it to toggle the highlight.
However, when in a table and I toggle the highlight off, on the slide I am on, the highlight toggles off, but in the slide layout and on the slide show (if running) the highlight remains. Is there something I am missing to force the highlight to toggle off?


Sub highlghtred()
Dim oShp As Shape
Dim oTbl As Table
Dim oTxtFrame As TextFrame
If ActiveWindow.Selection.Type = ppSelectionText Then
If Not ActiveWindow.Selection.TextRange.Parent Is Nothing Then
Set oTxtFrame = ActiveWindow.Selection.TextRange.Parent
Set oShp = oTxtFrame.Parent
Call ToggleShapeHighlight(oShp)
End If
End If
If ActiveWindow.Selection.Type = ppSelectionShapes Then
If ActiveWindow.Selection.HasChildShapeRange Then
Call ToggleHighlight(ActiveWindow.Selection.ChildShapeRange)
Else
Call ToggleHighlight(ActiveWindow.Selection.ShapeRange)
End If
Else
If ActiveWindow.Selection.Type <> ppSelectionNone Then
If ActiveWindow.Selection.ShapeRange.HasTable Then
For Each oShp In ActiveWindow.Selection.ShapeRange
If oShp.Type = msoTable Then
Call ToggleTableHighlight(oShp.Table)
End If
Next oShp
End If
End If
End If

End Sub

Sub ToggleHighlight(oShpRng As ShapeRange)
Dim shp As Shape
Dim ActiveShape As Shape
For Each shp In oShpRng
Set ActiveShape = shp
'MsgBox ("Shape color is currently " & shp.Fill.BackColor.RGB)
If ActiveShape.HasTextFrame Then
'MsgBox ("Found text " + ActiveShape.TextFrame.TextRange.Text)
If ActiveShape.TextFrame.TextRange.Text <> "" Then
Call ToggleShapeHighlight(ActiveShape)
End If
Else
If ActiveShape.Type = msoTable Then
Call ToggleTableHighlight(ActiveShape.Table)
End If
End If
Next shp
End Sub

Sub ToggleTableHighlight(oTbl As Table)
Dim x As Long
Dim y As Long
With oTbl
For x = 1 To .Rows.Count
For y = 1 To .Columns.Count
If .Cell(x, y).Selected Then
If .Cell(x, y).Shape.Fill.Visible = msoFalse Then
.Cell(x, y).Shape.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Cell(x, y).Shape.Fill.Solid
Else
.Cell(x, y).Shape.Fill.Visible = msoFalse
End If
End If
Next y
Next x
End With
End Sub

Sub ToggleShapeHighlight(oShp As Shape)
If oShp.Fill.Visible = msoFalse Then
oShp.Fill.ForeColor.RGB = RGB(255, 0, 0)
oShp.Fill.Solid
oShp.Fill.Visible = msoTrue
Else
oShp.Fill.Visible = msoFalse
End If
End Sub

[bcummins77]

I have managed to get this to work by assigning the contents of the cell to a string and then putting them back in the cell - it's inelegant but it works - I'm hoping someone might be able to assist with a better solution though.

Sub ToggleTableHighlight(oTbl As Table)
Dim x As Long
Dim y As Long
Dim strCell As String
With oTbl
For x = 1 To .Rows.Count
For y = 1 To .Columns.Count
If .Cell(x, y).Selected Then
If .Cell(x, y).Shape.Fill.Visible = msoFalse Then
.Cell(x, y).Shape.Fill.Visible = msoTrue
.Cell(x, y).Shape.Fill.Solid
.Cell(x, y).Shape.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
.Cell(x, y).Shape.Fill.Visible = msoFalse
strCell = .Cell(x, y).Shape.TextFrame.TextRange.Text
.Cell(x, y).Shape.TextFrame.TextRange.Text = strCell
End If
End If
Next y
Next x
End With
End Sub

[John Wilson]

I'm not sure there is a much better solution. Some changes do not seem to kick the thumbnail view to update. Usually i add a move left one point followed by a move right one point to give it a kick. Not exactly scientific but it seems to work.


Else
.Cell(x, y).Shape.Fill.Visible = msoFalse
.Parent.Left=.Parent.Left-1
.parent.Left=.Parent.Left+1

[bcummins77]

Thanks for replying John, I was hoping you would, I've seen many of your posts and they are usually spot on.
I was hoping there was one line of code that could do some kind of screen or presentation refresh, but I'll use what works.