Grouped Shapes Not Anchoring to Original Paragraph in Word VBA

ADAL · #1 12-12-2024, 03:32 AM

Hi everyone,

I have a VBA macro in Word that ungroups shapes, adjusts their positions and sizes, and then groups them back together. The problem is that after regrouping the shapes, the new group doesn't anchor to the original paragraph but instead anchors to another location in the document.

Here's my code:

Code:

Sub MACRO5()
    Dim shpGroup, C, L, R As Shape
    signon = Selection.Paragraphs(1).Style

    For Each para In ActiveDocument.Paragraphs
        para.Range.Select
        If para.Range.ShapeRange.Count > 0 Then
            If para.Style = signon And para.Range.ShapeRange(1).Name = "A" Then
                Set MYRANGE = para.Range
                MYRANGE.Select
                Selection.HomeKey
                PRINCIPIO = Selection.Information(wdHorizontalPositionRelativeToTextBoundary)
                Selection.EndKey
                FIN = Selection.Information(wdHorizontalPositionRelativeToTextBoundary)
                TAMANO = PRINCIPIO - FIN
                para.Range.ShapeRange(1).Select
                Set shpGroup = Selection.ShapeRange

                On Error GoTo iGroup
                shpGroup.Ungroup

                For Each shp In shpGroup
                    If shp.Name = "1" Then Set L = shp
                    If shp.Name = "2" Then Set C = shp
                    If shp.Name = "3" Then Set R = shp
                Next

                C.LockAspectRatio = msoFalse
                C.Width = TAMANO
                C.Left = C.Left - ADDITION_IN_EACH_SIDE
                L.Left = C.Left - L.Width
                R.Left = C.Left + C.Width

iGroup:
                shpGroup.Group
                shpGroup.Left = wdShapeCenter
            End If
        End If
    Next
End Sub

The macro works as intended, except the new group is not anchored to the original paragraph where the shapes were located. Instead, it appears to anchor elsewhere in the document.

How can I ensure that after regrouping, the shapes remain anchored to the original paragraph?

Any help or suggestions would be greatly appreciated!

Thank you in advance.

gmaxey · #2 12-12-2024, 04:28 AM

Why don't you post your document?

ADAL · #3 12-12-2024, 05:12 AM

Quote:

Originally Posted by gmaxey

Why don't you post your document?

I HAVE A TROUBLE UPLOADING NOW THE DOCUMNET BUT I CAN UPLOAD AN IMAGE ABOUT IT (I don’t need the macro for this specific document; this is just an example of what I need it for). I have decorative elements that need to be adjusted to the size of the text in the paragraph, as shown in the ATTACHED image.
SCREENSHOT1.png
My macro does the following:

Finds paragraphs with specific styles and shapes.
Ungroups the shapes.
Resizes and adjusts their positions based on the paragraph width.
Regroups the shapes.
AS YOU CAN SEE IN THE SECOND ATTACHED IMAGE
SCREENSHOT2.png
However, the issue is that after regrouping, the new group does not stay anchored to the original paragraph, which is what I need.

Thank you for your help!

gmaxey · #4 12-12-2024, 06:43 AM

Without you document, it is difficult to say. Recreating a document that could be used to test your code would take more time than I have to spend on this.

You might try declaring a variable and setting it to the shpGroup anchor before ungrouping and then setting the regrouped shpGroup anchor to that variable.

ADAL · #5 12-12-2024, 11:06 AM

Ok, thanks, here is the document
PRUEBAS.docx

gmaxey · #6 12-12-2024, 03:05 PM

Does this work?

Code:

Sub MACRO5()
Dim lngStart As Long, lngEnd As Long

    Dim shpGroup, C, L, R As Shape
    signon = Selection.Paragraphs(1).Style

    For Each para In ActiveDocument.Paragraphs
        para.Range.Select
        If para.Range.ShapeRange.Count > 0 Then
            If para.Style = signon And para.Range.ShapeRange(1).Name = "A" Then
                Set MYRANGE = para.Range
                MYRANGE.Select
                Selection.HomeKey
                PRINCIPIO = Selection.Information(wdHorizontalPositionRelativeToTextBoundary)
                Selection.EndKey
                FIN = Selection.Information(wdHorizontalPositionRelativeToTextBoundary)
                TAMANO = PRINCIPIO - FIN
                para.Range.ShapeRange(1).Select
                Set shpGroup = Selection.ShapeRange
                lngStart = shpGroup.Anchor.Start
                lngEnd = shpGroup.Anchor.End
                On Error GoTo iGroup
                shpGroup.Ungroup

                For Each shp In shpGroup
                    If shp.Name = "1" Then Set L = shp
                    If shp.Name = "2" Then Set C = shp
                    If shp.Name = "3" Then Set R = shp
                Next

                C.LockAspectRatio = msoFalse
                C.Width = TAMANO
                C.Left = C.Left - ADDITION_IN_EACH_SIDE
                L.Left = C.Left - L.Width
                R.Left = C.Left + C.Width

iGroup:
                shpGroup.Group
                shpGroup.Left = wdShapeCenter
                shpGroup.Anchor.Start = lngStart
                shpGroup.Anchor.End = lngEnd
            End If
        End If
    Next
End Sub

ADAL · #7 12-12-2024, 03:55 PM

First of all, thanks for the effort, but unfortunately, it doesn't work; it still moves the anchor to the paragraph above, as you can see in the picture:
3.png
I don't sure what you were trying to achieve with:

Code:

shpGroup.Anchor.Start = lngStart
shpGroup.Anchor.End = lngEnd

But the problem is that (according to what I read on the Office documentation) Anchor is a read-only property, so you can't change it.
Maybe macropod could know the answer, but I don't know how to tag him in the forum so he can see this post.

gmaxey · #8 12-12-2024, 04:08 PM

It could be that problem is due to the right to left paragraph alignment you have mixed into the text. The intent of lngStart and lngEnd was to re-anchor the shaperange to the original anchor point in the document.

macropod is in this group practically every day. If he is interested and can solve he will.

Guessed · #9 12-12-2024, 05:03 PM

There should be no need to ungroup the shapes as you can resize and move them as child elements. For instance,

Code:

            'shpGroup.Ungroup
            Debug.Print shpGroup.GroupItems.Count
            For Each shp In shpGroup.GroupItems
              If shp.Name = "1" Then Set L = shp
              If shp.Name = "2" Then Set C = shp
              If shp.Name = "3" Then Set R = shp
            Next

Having said that, I haven't taken the time to figure out the desired width and offsets and find the characters in the selected text stylename and right to left is not helping.

gmaxey · #10 12-12-2024, 05:52 PM

Andrew, I played around with that "GroupItems" for over an hour and can't get anything but errors with the document the user posted.

Beginning with Automation Errors.

ADAL · #11 12-13-2024, 03:45 AM

Quote:

Originally Posted by Guessed

There should be no need to ungroup the shapes as you can resize and move them as child elements. For instance,

Code:

            'shpGroup.Ungroup
            Debug.Print shpGroup.GroupItems.Count
            For Each shp In shpGroup.GroupItems
              If shp.Name = "1" Then Set L = shp
              If shp.Name = "2" Then Set C = shp
              If shp.Name = "3" Then Set R = shp
            Next

Having said that, I haven't taken the time to figure out the desired width and offsets and find the characters in the selected text stylename and right to left is not helping.

Hello,

The reason I'm reaching out is that Word VBA has a bug: while all measurements are typically in points, for some reason, when you use the Left property in GroupItems, it uses centimeters. This inconsistency is causing issues for me.

ADAL · #12 12-13-2024, 03:47 AM

Quote:

Originally Posted by gmaxey

It could be that problem is due to the right to left paragraph alignment you have mixed into the text. The intent of lngStart and lngEnd was to re-anchor the shaperange to the original anchor point in the document.

macropod is in this group practically every day. If he is interested and can solve he will.

Hello,

Thank you, but as I mentioned earlier, this is impossible because the Anchor property is read-only; it cannot be modified, as you can see in official office website:"Returns a Range object that represents the anchoring range for the specified shape or shape range. Read-only."

gmaxey · #13 12-13-2024, 09:05 AM

While correct in this case, I typically take what Microsoft documentation has to say about methods and properties with a grain of salt. True, I appears that the anchor can't be set with VBA and is "read only" as both you and the article has stated.

You mention "bug" in the GroupItems feature. Here at least, the Item method of GroupItems has failed and I couldn't do anything with it.

While I cannot explain why Grouped Shapes Not Anchoring to Original Paragraph in Word VBA, if I understand what your objective is, I might be able to offer a solution.

It appears that your have these multiple shaperanges with three (or in one case two) lines of text. Your goal is to adjust the width of the center shape to fit the text width of the last line in the shape. I'll call this the line of interest or variable width text line.

As we have seen, regardless of the hours trying to understand why and prevent, when the shaperange is ungrouped and regrouped the anchor shifts from your targeted line of interest to the top line in the applicable section. Seems there is nothing we can do to prevent that.

So, lets accept that our shapes are going to be anchored there anyway and start out with them anchored there. Now our problem is to a) find the shape and b) find the line of interest in that shape to use to calculate required center shape with.

I have done that in the attached PRUEBAS file. Now, your right to left text, and mix of English and Hebrew and perhaps even your styles caused me no end of frustration, but the process seems to meet the objective as I understand it.

Here is that code. You will need to revise it to meet all of your conditional requirements:

Code:

Sub MACRO5()
Dim shpGroup As ShapeRange
Dim C As Shape, L As Shape, R As Shape
Dim oPar As Paragraph
Dim oRng As Range
Dim oShp As Shape

  For Each oPar In ActiveDocument.Paragraphs
    If oPar.Range.ShapeRange.Count > 0 Then
      'The ShapeRanges in this document are anchored to the first paragraph in the sections.
      Set oRng = oPar.Range
      'Now we need to move the range down to the paragraph of interest e.g., the second or third
      'paragraphs covered by the shape range (or where you previoiusly had them anchored)
      Do Until Len(oRng.Paragraphs(1).Range.Text) > 1
        oRng.Move wdParagraph, 1
      Loop
      'We have now found the first paragraph with text.  Some of your shaperanges have three lines
      'where the second line is very small and formatted with a font named "Fb Livorna"
      If oRng.Paragraphs.Last.Next.Range.Font.Name = "Fb Livorna" Then
        'Move down 2 paragrphs.
        oRng.Move wdParagraph, 2
      Else
        'Your fourth shape does not have the "Fb Livorna" paragraph
        oRng.Move wdParagraph, 1
      End If
      'Now we have the paragraph of interest and need to determine how wide the
      'center shape should be.  This is a convoluted process and perhaps due to your right to left text,
      'or styles applied.  Regardless it works here.
      oRng.Paragraphs(1).Range.Characters.Last.Previous.Select
      PRINCIPIO = Selection.Information(wdHorizontalPositionRelativeToTextBoundary)
      oRng.Paragraphs(1).Range.Characters(1).Select
      Selection.EndKey
      FIN = Selection.Information(wdHorizontalPositionRelativeToTextBoundary)
      TAMANO = PRINCIPIO - FIN
      oPar.Range.ShapeRange(1).Select
      Set shpGroup = Selection.ShapeRange
      shpGroup.Ungroup
      For Each oShp In shpGroup
         If oShp.Name = "1" Then Set L = oShp
         If oShp.Name = "2" Then Set C = oShp
         If oShp.Name = "3" Then Set R = oShp
      Next
      C.LockAspectRatio = msoFalse
      C.Width = TAMANO
      C.Left = C.Left - ADDITION_IN_EACH_SIDE
      L.Left = C.Left - L.Width
      R.Left = C.Left + C.Width
     shpGroup.Group
     shpGroup.Left = wdShapeCenter
     End If
  Next
lbl_Exit:
  Exit Sub
End Sub

I have also attached Resize 3 part shape to fit text as and English left to right text example. Which for some inexplicable reason, it seemed much easier to calculate the required shape width. In this example I have named the shpGroup "Banner" and the three component parts "Left, Right and Center." I Have also used Range more that Selection. Here is that code:

Code:

Sub Resize3PartShapeToText()
Dim oPar As Paragraph
Dim shpGroup As ShapeRange
Dim C As Shape, L As Shape, R As Shape
Dim oRng As Range, oRngEval As Range
Dim oShp As Shape
Dim lngPositStart As Long, lngPositEnd As Long
  Application.ScreenUpdating = False
  For Each oPar In ActiveDocument.Paragraphs
    If oPar.Range.ShapeRange.Count > 0 Then
      If oPar.Range.ShapeRange(1).Name = "Banner" Then
        Set oRng = oPar.Range
        oRng.Select
        Do Until Len(oRng.Paragraphs(1).Range.Text) > 1
          'Finds the Fixed Line
          oRng.Move wdParagraph, 1
        Loop
        'Get the variable text line.
        oRng.Move wdParagraph, 1
        Set oRngEval = oRng.Paragraphs(1).Range.Duplicate
        oRngEval.Collapse wdCollapseStart
        lngPositStart = oRngEval.Information(wdHorizontalPositionRelativeToTextBoundary)
        Set oRngEval = oRng.Paragraphs(1).Range.Duplicate
        oRngEval.Collapse wdCollapseEnd
        oRngEval.Move wdCharacter, -1
        lngPositEnd = oRngEval.Information(wdHorizontalPositionRelativeToTextBoundary)
        Set shpGroup = oPar.Range.ShapeRange
        shpGroup.Ungroup
        For Each oShp In shpGroup
          Select Case oShp.Name
            Case "Left": Set L = oShp
            Case "Center": Set C = oShp
            Case "Right": Set R = oShp
          End Select
        Next
        C.LockAspectRatio = msoFalse
        C.Width = lngPositEnd - lngPositStart
        C.Left = C.Left
        L.Left = C.Left - L.Width
        R.Left = C.Left + C.Width
        shpGroup.Group
        shpGroup.Name = "Banner"
        shpGroup.Left = wdShapeCenter
        shpGroup.Height = 99.5
      End If
    End If
  Next
  Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub

This is about all I can offer. Perhaps as you say, macropod will come along with the answer. Good Luck.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Get rid of auto-numbering, but keep the original paragraph numbers	qubie	Word	6	05-21-2020 05:09 PM
Outlook increases paragraph spacing when including original in reply	Bud	Outlook	0	05-13-2016 11:51 PM
Exporting Grouped Shapes	JamesEddy	Word	4	12-08-2014 08:16 AM
Grouped Shapes > "Save Picture As"	JamesEddy	Word	0	10-29-2014 01:29 PM
Anchoring photo to paragraph	tharmon	Drawing and Graphics	3	06-07-2012 03:43 PM