Thanks! I used the toolbar add-in code with the highlighting code and picked
some new Face ID icons and that did the trick
It throws an error if no
text is selected and you click the button but maybe I can fix that eventually
too
Here is what worked:
Sub Auto_Open()
Dim oToolbar As CommandBar
Dim oButton As CommandBarButton
Dim MyToolbar As String
' Give the toolbar a name
MyToolbar = "HLite"
On Error Resume Next
' so that it doesn't stop on the next line if the toolbar's already there
' Create the toolbar; PowerPoint will error if it already exists
Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
Position:=msoBarFloating, Temporary:=True)
If Err.Number <> 0 Then
' The toolbar's already there, so we have nothing to do
Exit Sub
End If
On Error GoTo ErrorHandler
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Highlight Text"
'Tooltip text when mouse if placed over button
.Caption = "Highlight Text"
'Text if Text in Icon is chosen
.OnAction = "Button1"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 1715
' chooses icon #1715 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Unhighlight Text"
'Tooltip text when mouse if placed over button
.Caption = "Unhighlight Text"
'Text if Text in Icon is chosen
.OnAction = "Button2"
'Runs the Sub Button2() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 1716
' chooses icon #1716 from the available Office icons
End With
' Repeat the above for as many more buttons as you need to add
' Be sure to change the .OnAction property at least for each new button
' You can set the toolbar position and visibility here if you like
' By default, it'll be visible when created
oToolbar.Top = 150
oToolbar.Left = 150
oToolbar.Visible = True
NormalExit:
Exit Sub ' so it doesn't go on to run the errorhandler code
ErrorHandler:
'Just in case there is an error
MsgBox Err.Number & vbCrLf & Err.Description
Resume NormalExit:
End Sub
Sub Button1()
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.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 Button2()
' 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
