Word VBA to add line the length of selection - vba

Question

I would like to write a Word VBA macro that inserts a vertical line the length of the selected text.
apos = Int(Selection.Information(6))
Set aLine = ActiveDocument.Shapes.AddLine(26, apos, 26, apos + 40)
aLine.Select
With Selection
.ShapeRange.Line.Weight = 3#
.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Style = msoLineSingle
.ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)
End With
But that code adds the vertical line length of "40"
How do I adjust the length "40" to be the length of the selected text?
Thank you

Answer 1

Use exactly the same method by which you have determined the beginning of the line. The end is at the Information(wdHorizontalPositionRelativeToPage) of the last character in the Selection + 1. Here is the complete code.
Private Sub LineUnderSelection()
' 08 May 2017
Dim Rng As Range
Dim FontHeight As Single, ParaSpace As Single
Dim LineStart As Single, LineEnd As Single
With Selection
With .Range
Do While Asc(.Text) < 48
' remove excluded characters at start
.MoveEnd wdCharacter, 1
Loop
Do While Asc(Right(.Text, 1)) < 48
' remove excluded characters at end
.MoveEnd wdCharacter, -1
Loop
LineStart = .Information(wdHorizontalPositionRelativeToPage)
Set Rng = Selection.Range
Rng.SetRange .End, .End
FontHeight = Int(Rng.Font.Size)
ParaSpace = 2 - Rng.Paragraphs(1).SpaceBefore
If ParaSpace < -3 Then ParaSpace = -3
LineEnd = Rng.Information(wdHorizontalPositionRelativeToPage)
SetLine ActiveDocument, "Underscore", LineStart, LineEnd - LineStart, _
.Information(wdVerticalPositionRelativeToPage) _
+ FontHeight + ParaSpace, 1.5, vbRed
End With
End With
End Sub
As you see, I found out that the extra character isn't needed. Word extends the line to the end of the character automatically. In the process of finding this out I also discovered that Word doesn't like to underline returns. Therefore the code excludes all characters with an ASCII code of less than 48 (represents the character 1). I then applied the same rule to leading characters, likewise removing them from the selection. Please run your own tests if this is enough or too much. There are lots of characters with a code > 128 which might be offensive.
The code takes the size of the last character and adds its height to the vertical position. This is to place the line under the selected text, not above it. I added 2 points to keep a little space between the text and the line.
Word takes note of space before. Your selection might contain several paragraphs. My code only looks at the paragraph of which the last character is a member. Word seems to place the line about 3 points lower if there is SpaceBefore in the paragraph's format, almost regardless of how big that space is. But if the space is smaller than 3pt the line will be lowered correspondingly less. This examination led to this code.
ParaSpace = 2 - Rng.Paragraphs(1).SpaceBefore
If ParaSpace < -3 Then ParaSpace = -3
You may like to amend this code to place the line more precisely. You will see that the vertical position consists of the position of the selection + FondtSize + ParaSpacing.
All of the above code creates the parameters which are fed to another sub which creates the actual line. Observe that the parameters include the line width and setting the Activedocument as target and giving a name to the line. It is possible to give the same name repeatedly. Word will use its own names in additon, and they are unique. Here is the code that inserts the line. (You may prefer to make it Private)
Function SetLine(Story As Object, _
Lname As String, _
Lleft As Single, _
Llength As Single, _
Ltop As Single, _
Lwidth As Single, _
Lcol As Long) As Shape
' 20 Aug 2016
Dim Fun As Shape
Set Fun = Story.Shapes.AddLine(Lleft, Ltop, Lleft + Llength, Ltop)
With Fun
.Title = Lname
.Name = Lname
.LockAspectRatio = msoTrue
With .Line
.Weight = Lwidth
.ForeColor = Lcol
End With
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Visible = msoTrue
.WrapFormat.AllowOverlap = msoTrue
.LayoutInCell = msoFalse
.ZOrder msoSendBehindText
.LockAnchor = msoTrue
End With
Set SetLine = Fun
End Function
This code includes a lot of parameters which are not variable by means of the arguments it receives, such as LockAnchor, ZOrder etc. You may wish to change these to better meet your requirements.