Word Macro issues (Circle Shape)

syl3786 · #1 04-21-2024, 11:59 PM

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.

Guessed · #2 04-22-2024, 04:13 AM

Give this version a try

Code:

Sub AddCircleShape()
  Dim rng As Range, stri As String, shp As Shape
  Dim padding As Long, rightCount As Integer
  Dim X As Long, Y As Long, myWidth As Long, myHeight As Long
  
  Set rng = ActiveDocument.Range
  stri = "AGREE/"
  padding = 2
  With rng.Find
    .Text = stri
    .Font.Underline = True
    .Execute
    While .Found
      ' Calculate the position and size of the circle
      myHeight = IIf(rng.ParagraphFormat.LineSpacing > rng.Font.Size, rng.ParagraphFormat.LineSpacing, rng.Font.Size * 1.2)
      Y = rng.Information(wdVerticalPositionRelativeToPage) - myHeight / 10 + myHeight - (rng.Font.Size * 1.2)
      myHeight = rng.Font.Size * 1.2        ' 120%
      X = rng.Information(wdHorizontalPositionRelativeToPage) - padding
      rng.Collapse wdCollapseEnd
      myWidth = rng.Information(wdHorizontalPositionRelativeToPage) + padding - X
      myHeight = myHeight + padding * 2
      
      ' Add the circle shape
      Set shp = ActiveDocument.Shapes.AddShape(msoShapeOval, X, Y, myWidth, myHeight)
      With shp
        .ZOrder msoSendBehindText
        .Fill.Transparency = 1 ' Full transparency
        .Line.ForeColor.RGB = RGB(0, 112, 192)
        .Line.Weight = 1
        .Line.Visible = msoTrue
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        .RelativeVerticalPosition = wdRelativeVerticalPositionPage
      End With
      
      rng.Collapse wdCollapseEnd
      .Execute
      Wend
  End With
End Sub

syl3786 · #3 04-22-2024, 04:58 AM

Quote:

Originally Posted by Guessed

Give this version a try

Code:

Sub AddCircleShape()
  Dim rng As Range, stri As String, shp As Shape
  Dim padding As Long, rightCount As Integer
  Dim X As Long, Y As Long, myWidth As Long, myHeight As Long
  
  Set rng = ActiveDocument.Range
  stri = "AGREE/"
  padding = 2
  With rng.Find
    .Text = stri
    .Font.Underline = True
    .Execute
    While .Found
      ' Calculate the position and size of the circle
      myHeight = IIf(rng.ParagraphFormat.LineSpacing > rng.Font.Size, rng.ParagraphFormat.LineSpacing, rng.Font.Size * 1.2)
      Y = rng.Information(wdVerticalPositionRelativeToPage) - myHeight / 10 + myHeight - (rng.Font.Size * 1.2)
      myHeight = rng.Font.Size * 1.2        ' 120%
      X = rng.Information(wdHorizontalPositionRelativeToPage) - padding
      rng.Collapse wdCollapseEnd
      myWidth = rng.Information(wdHorizontalPositionRelativeToPage) + padding - X
      myHeight = myHeight + padding * 2
      
      ' Add the circle shape
      Set shp = ActiveDocument.Shapes.AddShape(msoShapeOval, X, Y, myWidth, myHeight)
      With shp
        .ZOrder msoSendBehindText
        .Fill.Transparency = 1 ' Full transparency
        .Line.ForeColor.RGB = RGB(0, 112, 192)
        .Line.Weight = 1
        .Line.Visible = msoTrue
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        .RelativeVerticalPosition = wdRelativeVerticalPositionPage
      End With
      
      rng.Collapse wdCollapseEnd
      .Execute
      Wend
  End With
End Sub

Thank you for your assistance. I attempted to use your code, but the circle seems to be flying over a random area of the document and the size of the circle isn't accurate.

Guessed · #4 04-22-2024, 06:27 AM

You are right, getting the X position is confounded when the text is not simply left aligned. Your example document has justified text and the values calculated for the horizontal alignment positions are inaccurate. I also tried using the Selection object but wasn't getting predictable results there either.

Can I ask what is the point of sticking a circle around text? Wouldn't it be a whole lot easier to just apply highlight to that text?

syl3786 · #5 04-22-2024, 08:31 PM

Quote:

Originally Posted by Guessed

You are right, getting the X position is confounded when the text is not simply left aligned. Your example document has justified text and the values calculated for the horizontal alignment positions are inaccurate. I also tried using the Selection object but wasn't getting predictable results there either.

Can I ask what is the point of sticking a circle around text? Wouldn't it be a whole lot easier to just apply highlight to that text?

The company has established a rule whereby a designated officer is mandated to attend meetings and notate whether members concur with a proposed item. It is compulsory for the officer to circle these endorsements. Using a computer, the officer will comprehensively record all details discussed in the meeting. This is part of a macro process in preparation for the meeting. The default setting is to specifically circle 'AGREE'.

Guessed · #6 04-23-2024, 05:00 AM

Sounds like this macro is complying with the policy but absolutely not the intent of the rule #maliciouscompliance

I'm not going to fiddle with this further to see if I can figure out how to consistently deal with the location of the circle. Instead, I would explore a workaround of just using the vertical position and apply a consistent horizontal location for the circle (out in the margin area) so your officer can see all the circles down the edge of the page and choose to tick them off as a progress record during the meeting.

syl3786 · #7 04-23-2024, 06:06 AM

Quote:

Originally Posted by Guessed

Sounds like this macro is complying with the policy but absolutely not the intent of the rule #maliciouscompliance

I'm not going to fiddle with this further to see if I can figure out how to consistently deal with the location of the circle. Instead, I would explore a workaround of just using the vertical position and apply a consistent horizontal location for the circle (out in the margin area) so your officer can see all the circles down the edge of the page and choose to tick them off as a progress record during the meeting.

I appreciate your willingness to explore alternative solutions. Your proposed workaround of using the vertical position and applying a consistent horizontal location for the circle is a great idea.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Seeking Assistance with Word Macro to Add Transparent, Blue Line Circle Shape	syl3786	Word VBA	5	01-21-2024 03:41 AM
put "page numbers" in a shape (e.g. circle) without missing the numbers in the document	Abbas	Word	1	07-26-2022 07:04 AM
Word 2016 Multi-file Macro issues	IneedHelpWithWord	Word VBA	1	08-08-2017 09:29 PM
Issues with text in circle shapes that I am having	damefrombrum	Word	0	12-01-2015 08:05 PM
Assign Macro to Shape in Word 2013	tunes10590	Word VBA	8	01-29-2015 06:26 AM