View Single Post
 
Old 04-21-2024, 11:59 PM
syl3786 syl3786 is offline Windows 10 Office 2019
Advanced Beginner
 
Join Date: Jan 2023
Posts: 97
syl3786 is on a distinguished road
Unhappy Word Macro issues (Circle Shape)

Hello all,

Presently, I am utilizing a particular Word macro to add a distinct circle shape over specific text:

Code:
Sub AddCircleShape()

    Dim rng As Range
    Dim stri As String
    Dim shp As Shape
    Dim padding As Long
    Dim rightCount As Integer
    Dim X, Y, myWidth, myHeight
    
    Set rng = ActiveDocument.Range
    stri = "AGREE/" 

    With rng.Find
        .Text = stri
        .Font.Underline = True
        .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
            myWidth = myWidth - 40
            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

    rightCount = 30
    
    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.Left = shp.Left + rightCount
            End If
        End If
    Next shp
    
        For Each shp In ActiveDocument.Shapes
        If shp.AutoShapeType = msoShapeOval Then
            shp.Line.ForeColor.RGB = RGB(0, 112, 192)
            shp.Line.Visible = msoTrue
        End If
    Next shp
    
    Selection.Collapse

End Sub
Nonetheless, I've been encountering an occasional glitch with the macro. The issue lies in the first circle it creates, which never seems to be the right size to encompass the designated text.

Here's the sample document for your testing:

Sample Document.docx

Expected Result.docx

Would any of you be able to assist with rectifying this problem? I would greatly appreciate any help. Thank you in advance.
Reply With Quote