Add cricle shape over specific text

yanlok1345
StarLounger
Posts: 84
Joined: 18 Oct 2023, 14:48

Add cricle shape over specific text

Post by 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
You do not have the required permissions to view the files attached to this post.
Last edited by yanlok1345 on 05 Feb 2024, 04:25, edited 1 time in total.

User avatar
HansV
Administrator
Posts: 78962
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Add cricle shape over specific text

Post by HansV »

Please attach a small sample document that shows the problem.
Best wishes,
Hans

yanlok1345
StarLounger
Posts: 84
Joined: 18 Oct 2023, 14:48

Re: Add cricle shape over specific text

Post by yanlok1345 »

HansV wrote:
04 Feb 2024, 11:29
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

User avatar
HansV
Administrator
Posts: 78962
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Add cricle shape over specific text

Post by HansV »

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

yanlok1345
StarLounger
Posts: 84
Joined: 18 Oct 2023, 14:48

Re: Add cricle shape over specific text

Post by yanlok1345 »

HansV wrote:
04 Feb 2024, 13:11
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.

User avatar
HansV
Administrator
Posts: 78962
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Add cricle shape over specific text

Post by 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.
Best wishes,
Hans

User avatar
Charles Kenyon
5StarLounger
Posts: 642
Joined: 10 Jan 2016, 15:56
Location: Madison, Wisconsin

Re: Add cricle shape over specific text

Post by 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

User avatar
SpeakEasy
5StarLounger
Posts: 600
Joined: 27 Jun 2021, 10:46

Re: Add cricle shape over specific text

Post by 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
StarLounger
Posts: 84
Joined: 18 Oct 2023, 14:48

Re: Add cricle shape over specific text

Post by yanlok1345 »

SpeakEasy wrote:
07 Feb 2024, 09:50
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?

User avatar
SpeakEasy
5StarLounger
Posts: 600
Joined: 27 Jun 2021, 10:46

Re: Add cricle shape over specific text

Post by SpeakEasy »

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

yanlok1345
StarLounger
Posts: 84
Joined: 18 Oct 2023, 14:48

Re: Add cricle shape over specific text

Post by yanlok1345 »

SpeakEasy wrote:
12 Feb 2024, 10:50
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.

User avatar
SpeakEasy
5StarLounger
Posts: 600
Joined: 27 Jun 2021, 10:46

Re: Add cricle shape over specific text

Post by 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

User avatar
Leif
Administrator
Posts: 7242
Joined: 15 Jan 2010, 22:52
Location: Middle of England

Re: Add cricle shape over specific text

Post by Leif »

Could it have anything to do with the font?
Leif

yanlok1345
StarLounger
Posts: 84
Joined: 18 Oct 2023, 14:48

Re: Add cricle shape over specific text

Post by yanlok1345 »

Leif wrote:
12 Feb 2024, 17:14
Could it have anything to do with the font?
Certainly. I applied this macro to non-English text.