CODEWITHSUNDEEP
vbams-word
danjedi
danjedi

Reputation: 25

Word VBA to add line the length of selection

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

Upvotes: 1

Views: 1240

Answers (1)

Variatus
Variatus

Reputation: 14373

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.

Upvotes: 1

Related Questions