![]() |
#1
|
|||
|
|||
![]()
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 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. |
#2
|
|||
|
|||
![]()
Why don't you post your document?
|
#3
|
|||
|
|||
![]()
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! Last edited by ADAL; 12-12-2024 at 05:13 AM. Reason: MISTAKE |
#4
|
|||
|
|||
![]()
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. |
#5
|
|||
|
|||
![]()
Ok, thanks, here is the document
PRUEBAS.docx |
#6
|
|||
|
|||
![]()
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 |
#7
|
|||
|
|||
![]()
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 Maybe macropod could know the answer, but I don't know how to tag him in the forum so he can see this post. |
#8
|
|||
|
|||
![]()
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. |
#9
|
||||
|
||||
![]()
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#10
|
|||
|
|||
![]()
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. |
#11
|
|||
|
|||
![]() Quote:
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. |
#12
|
|||
|
|||
![]() Quote:
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." |
#13
|
|||
|
|||
![]()
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 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 Last edited by gmaxey; 12-13-2024 at 02:34 PM. |
![]() |
Tags |
shapes, vba |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
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 |
![]() |
JamesEddy | Word | 4 | 12-08-2014 08:16 AM |
Grouped Shapes > "Save Picture As" | JamesEddy | Word | 0 | 10-29-2014 01:29 PM |
![]() |
tharmon | Drawing and Graphics | 3 | 06-07-2012 03:43 PM |