Add cricle shape over specific text

[yanlok1345]

Hi all,

I'm working on developing a word macro that adds a circle shape over specific text. I've already created the macro, but I'm experiencing some issues with the accuracy of the circle shape placement.

Code: Select all

Sub ACS()
    
    Dim rng As Range
    Dim stri As String
    Dim shp As Shape
    
    Set rng = ActiveDocument.Range
    stri = "ABCD／"
    
    With rng.Find
        .Text = stri
        .Execute
        While .found
            rng.Select
            Set shp = ActiveDocument.Shapes.AddShape(msoShapeOval, _
            Selection.Information(wdHorizontalPositionRelativeToPage), _
            Selection.Information(wdVerticalPositionRelativeToPage), _
            65, 25)
            With shp
                .Fill.Transparency = 1 'Full transparency
                .Line.ForeColor.RGB = RGB(255, 0, 0)
                .Line.Weight = 1
                .Line.Visible = msoTrue
            End With
            rng.Collapse wdCollapseEnd
            .Execute
        Wend
    End With
    
End Sub

I've noticed that the circle is more accurate on pages with smaller linespacing, but not so much on pages with larger linespacing. I've tried adjusting the numbers using +, -, *, and /, placing after "Selection.Information(wdHorizontalPositionRelativeToPage)" and "Selection.Information(wdVerticalPositionRelativeToPage)" but I haven't been able to solve the issue.

If any of you could offer any assistance on how to improve the accuracy of the macro, it would be greatly appreciated!

ABCD.docx

[HansV]

Please attach a small sample document that shows the problem.

[yanlok1345]

Please attach a small sample document that shows the problem.

I apologize for the document being confidential. Unfortunately, I am unable to upload it as an attachment. However, I believe that regardless of the documents involved, the issue may lie within the following lines of code:

Selection.Information(wdHorizontalPositionRelativeToPage), _
Selection.Information(wdVerticalPositionRelativeToPage), _

I attempted to modify it as follows:

Selection.Information(wdHorizontalPositionRelativeToPage) + 6, _
Selection.Information(wdVerticalPositionRelativeToPage) - 6, _

Despite making these edits, the problem persists.

I also tried to move circle shape by the following macro:

Code: Select all

Sub MCS()

    Dim shp As Shape
    Dim downCount As Integer
    Dim leftCount As Integer
    
    downCount = 2
    leftCount = 1.5
    
    For Each shp In ActiveDocument.Shapes
        If shp.AutoShapeType = msoShapeOval Then
            If shp.Line.ForeColor.RGB = RGB(255, 0, 0) Then
                shp.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
                shp.RelativeVerticalPosition = wdRelativeVerticalPositionPage
                shp.Top = shp.Top + downCount
                shp.Left = shp.Left - leftCount
            End If
        End If
    Next shp

End Sub

[HansV]

Can't you create a small non-confidential document that demonstrates the problem?

[yanlok1345]

Can't you create a small non-confidential document that demonstrates the problem?

I attached a sample for you. In page 2, the linespacing is 33, you can see the circle added is not accurate.

[HansV]

Thank you. I hope that this will enable someone to come up with a suggestion.
I don't know enough about Word to help you.

[Charles Kenyon]

I do not have experience in working with shapes and vba, really.
Here is a temporary link to a template that might give you a start.
https://www.dropbox.com/scl/fi/wwcg43f8 ... pk1q6&dl=0

It is based on your sample and contains two AutoText entries, each attached to a keyboard shortcut. That might be the basis for you to do something. The difference is the spacing. If you need to use a macro, here is a link to instructions on using macros to insert building blocks.
https://www.addbalance.com/usersguide/a ... ldingBlock

[SpeakEasy]

Part of the problem is that Selection.Information(wdVerticalPositionRelativeToPage) does not return the position of the top of the font; it includes any linespaceing/leading that has been applied. And Microsoft applies some arcane internal rules about how leading is distributed that we don't have access to (for example linespacing of 1, i.e font height, is actually 120% of the font height)

This sub is an illustration of sort of dealing with this.

Code: Select all

Public Sub CircleCurrentSelection()
    Dim padding As Long
    Dim myRange As Range
    Set myRange = Selection.Range
    
    Dim x, y, mywidth, myheight
    
    ' Choose whether we use linespacing or fontheight for basic height. This is realy where the trouble lies,
    ' as Microsofts linespacing follows some arcane internal rules that are not expposed; e.g Single line spacing (i.e font height) is actually 120%, not 100%
    ' Soi we need  to try and calculate y (i.e top) of required bounding box,
    myheight = IIf(Selection.ParagraphFormat.LineSpacing > myRange.Font.Size, Selection.ParagraphFormat.LineSpacing, myRange.Font.Size + myRange.Font.Size / 5)
    y = myRange.Information(wdVerticalPositionRelativeToPage) - myheight / 10 + myheight - myRange.Font.Size - myRange.Font.Size / 5
    myheight = myRange.Font.Size + myRange.Font.Size / 5 ' 120%
    
    ' width is the easy  one ...
    x = myRange.Information(wdHorizontalPositionRelativeToPage)
    myRange.Collapse wdCollapseEnd
    mywidth = myRange.Information(wdHorizontalPositionRelativeToPage) - x
    
    padding = 2
    x = x - padding
    y = y - padding
    mywidth = mywidth + padding * 2
    myheight = myheight + padding * 2
    
    With ActiveDocument.Shapes.AddShape(msoShapeOval, x, y, mywidth, myheight)
        .PictureFormat.TransparentBackground = True
        .Line.ForeColor.RGB = RGB(255, 0, 0)
    End With

End Sub

[yanlok1345]

Part of the problem is that Selection.Information(wdVerticalPositionRelativeToPage) does not return the position of the top of the font; it includes any linespaceing/leading that has been applied. And Microsoft applies some arcane internal rules about how leading is distributed that we don't have access to (for example linespacing of 1, i.e font height, is actually 120% of the font height)

This sub is an illustration of sort of dealing with this.

Code: Select all

Public Sub CircleCurrentSelection()
    Dim padding As Long
    Dim myRange As Range
    Set myRange = Selection.Range
    
    Dim x, y, mywidth, myheight
    
    ' Choose whether we use linespacing or fontheight for basic height. This is realy where the trouble lies,
    ' as Microsofts linespacing follows some arcane internal rules that are not expposed; e.g Single line spacing (i.e font height) is actually 120%, not 100%
    ' Soi we need  to try and calculate y (i.e top) of required bounding box,
    myheight = IIf(Selection.ParagraphFormat.LineSpacing > myRange.Font.Size, Selection.ParagraphFormat.LineSpacing, myRange.Font.Size + myRange.Font.Size / 5)
    y = myRange.Information(wdVerticalPositionRelativeToPage) - myheight / 10 + myheight - myRange.Font.Size - myRange.Font.Size / 5
    myheight = myRange.Font.Size + myRange.Font.Size / 5 ' 120%
    
    ' width is the easy  one ...
    x = myRange.Information(wdHorizontalPositionRelativeToPage)
    myRange.Collapse wdCollapseEnd
    mywidth = myRange.Information(wdHorizontalPositionRelativeToPage) - x
    
    padding = 2
    x = x - padding
    y = y - padding
    mywidth = mywidth + padding * 2
    myheight = myheight + padding * 2
    
    With ActiveDocument.Shapes.AddShape(msoShapeOval, x, y, mywidth, myheight)
        .PictureFormat.TransparentBackground = True
        .Line.ForeColor.RGB = RGB(255, 0, 0)
    End With

End Sub

Wow! That's what I am seeking! Many thanks for youe help! I edited as follows:

Code: Select all

Sub AddCircleOverSpecificText()
    Dim rng As Range
    Dim stri As String
    Dim shp As Shape
    Dim padding As Long
    Dim x, y, mywidth, myheight

    Set rng = ActiveDocument.Range
    stri = "ABCD／" ' Set your specific text here

    With rng.Find
        .Text = stri
        .Execute
        While .found
            rng.Select
            
            ' Calculate the position and size of the circle
            myheight = IIf(Selection.ParagraphFormat.LineSpacing > rng.Font.Size, Selection.ParagraphFormat.LineSpacing, rng.Font.Size + rng.Font.Size / 5)
            y = rng.Information(wdVerticalPositionRelativeToPage) - myheight / 10 + myheight - rng.Font.Size - rng.Font.Size / 5
            myheight = rng.Font.Size + rng.Font.Size / 5 ' 120%
            x = rng.Information(wdHorizontalPositionRelativeToPage)
            rng.Collapse wdCollapseEnd
            mywidth = rng.Information(wdHorizontalPositionRelativeToPage) - x
            padding = 2
            x = x - padding
            y = y - padding
            mywidth = mywidth + padding * 2
            myheight = myheight + padding * 2
            
            ' Add the circle shape
            Set shp = ActiveDocument.Shapes.AddShape(msoShapeOval, x, y, mywidth, myheight)
            With shp
                .Fill.Transparency = 1 ' Full transparency
                .Line.ForeColor.RGB = RGB(255, 0, 0)
                .Line.Weight = 1
                .Line.Visible = msoTrue
            End With
            
            rng.Collapse wdCollapseEnd
            .Execute
        Wend
    End With
End Sub

However, I'm having an issue with the circle shape's width when there is text before and after "ABCD/". It doesn't seem to be correct. The width exceeds the width of the stri text. I attempted to solve the problem myself, but unfortunately, I wasn't successful. Do you have any suggestions on how to enhance this?

[SpeakEasy]

Should just need to modify the padding value - change from 2 to 0

[yanlok1345]

Should just need to modify the padding value - change from 2 to 0

Thank you for your response. I attempted but unfortunately, the problem persists. Since this macro calculates the width of the circle shape based on the width of the specific text, I am uncertain if this is the underlying cause of the incorrect width being applied.

[SpeakEasy]

Have to say I am not seeing the problem you describe here. Circles (well, ellipses) draw with correct width for me using my code

[Leif]

Could it have anything to do with the font?

[yanlok1345]

Could it have anything to do with the font?

Certainly. I applied this macro to non-English text.