Word shading exactly to text height - vba

Question

I'm currently working on a MS Word report.
To highlight certain sections, it would be great to shade some part of the text as seen in beneath image:
Unfortunately, I'm just able to add the shading for the full line height, as shown in the following image:
Is there a native way inside MS Word to accomplish the shading for just the text height?
Otherwise I'm forced to embed images inside my report as the headings (This is something I do not want for several reasons, e.g. complications in Table of Contents)

Answer 1

There is no direct way to have a shading as you desire, it's always to the full line height and not the cap height. And this also makes sense, when you think about how the shading would look like for letters with a tail (such as uppercase Q or a descender (such as lowercase g).
If you want to add the shading to single lines only you could mimic the desired effect by anchoring a rectangle shape to the paragraph and position it behind the text.
Here is a quick and dirty VBA macro that adds shading using shapes to the selected lines of text. You have to fine-tune the height and vertical offset of the shapes to the font and font size you are using.
Sub AddShading()
Dim rng As Range
Dim startPos As Integer
Dim endPos As Integer
Dim capHeight As Single
capHeight = 8
Dim verticalOffset As Single
verticalOffset = 3
' backup original select
Set rng = Selection.Range.Duplicate
' start undo transaction
Application.UndoRecord.StartCustomRecord "Add Shading"
Do
' select line of text
Selection.Collapse
Selection.Expand wdLine
If Selection.Start < rng.Start Then
Selection.Start = rng.Start
End If
If Selection.End > rng.End Then
Selection.End = rng.End
End If
' get range of current line to be able to retrieve position of line
Dim rngLine As Range
Set rngLine = Selection.Range.Duplicate
' get the left coordinate
Dim left As Single
left = rngLine.Information(wdHorizontalPositionRelativeToPage)
' get the top coordinate and add a vertical adjustment depending on the font used
Dim top As Single
top = rngLine.Information(wdVerticalPositionRelativeToPage) + verticalOffset
' move to the end position of the line
rngLine.Collapse wdCollapseEnd
If rngLine.Information(wdVerticalPositionRelativeToPage) > top Then
rngLine.Move wdCharacter, -1
End If
' calculate width of line
Dim width As Integer
width = rngLine.Information(wdHorizontalPositionRelativeToPage) - left
' add shape behind text
Dim shp As Shape
Set shp = rng.Document.Shapes _
.AddShape(msoShapeRectangle, left, top, width, capHeight, rng)
With shp
' grey shading
.Fill.ForeColor.RGB = RGB(192, 192, 192)
' no outline
.Line.Visible = msoFalse
' the shape should move with the text
.RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
' position the shape behind the text
.WrapFormat.Type = wdWrapBehind
End With
' continue with next line
Selection.Move wdLine
Loop While Selection.End < rng.End
' restore original selection
rng.Select
Application.UndoRecord.EndCustomRecord
End Sub