TPE

Tavvafi@gmail.com

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

Sub Highlight()

    Dim oRng As TextRange
    Dim lLineCount As Long
    Dim oRect As Shape
    Dim dOffset As Double
    Dim lFillColor As Long

    ' EDIT THESE AS NEEDED
    ' dOffset sets the amount of padding added around the text (in points)
    dOffset = 2
    ' change this to get a different highlight color
    lFillColor = RGB(255, 255, 128)

    With ActiveWindow.Selection.TextRange
        For lLineCount = 1 To .Lines.Count
            Set oRng = .Lines(lLineCount)
            With oRng
                Set oRect = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, _
                    .BoundLeft - dOffset, _
                    .BoundTop - dOffset, _
                    .Boundwidth + dOffset, _
                    .Boundheight + dOffset)
                With oRect
                    ' format it
                    .Fill.Visible = msoTrue  ' in case default fill's set to invisible
                    .Fill.ForeColor.RGB = lFillColor
                    .Line.Visible = msoFalse
                    ' tag it so we can find/delete it later
                    Call .Tags.Add("Highlight", "YES")
                    ' send it behind the text
                    While Not .ZOrderPosition < ActiveWindow.Selection.ShapeRange(1).ZOrderPosition
                        .ZOrder msoSendBackward
                    Wend
                End With
            End With
        Next
    End With

End Sub

Sub UnHighlight()
' Removes highlights

    Dim oSh As Shape
    Dim x As Long

    With ActiveWindow.Selection.SlideRange(1)
        For x = .Shapes.Count To 1 Step -1
            Set oSh = .Shapes(x)
            If oSh.Tags("Highlight") = "YES" Then
                oSh.Delete
            End If
        Next
    End With

End Sub