I make a selection (top) and then run my macro and though the macro does fine it leaves the selection in this state (bottom) whereby requiring me to deselect and select again
What is my code missing?
Sub BreakDimensions()Optimization = TrueActiveDocument.BeginCommandGroup "BreakDimension" Dim sr As ShapeRange, s As Shape Set sr = ActiveSelectionRange For Each s In sr If Not s.Type = cdrLinearDimensionShape Then s.RemoveFromSelection End If Next s ActiveSelection.BreakApart sr.AddToSelection sr.Group Optimization = False ActiveDocument.EndCommandGroup End Sub
For-Next loop can probably be replaced by
Set sr = ActiveSelectionRange.FindShapes(, cdrLinearDimensionShape )
I am assuming you want to break apart the dimensions so you can group the shapes and dimensions on the layer to easily rescale it for your documents.
again that only leaves the dimensions selected. It needs to select everything that was selected before running the macro
I tried it in mine and it selected everything even though it seemed like it didn't. Move it and see.
This should work like you need. Except the case when you have some other Text shapes besides the ones belonging to the dimension shapes. In such a case I will name them in a specific way and filter based on that the sr RangeShape in order to be removed.
Dim sr As ShapeRange, s As Shape, srBis As ShapeRange, sGr As Shape, i As Long
Set sr = ActiveSelectionRange
For Each s In sr
If Not s.Type = cdrLinearDimensionShape And Not s.Type = cdrTextShape Then
i = i + 1
Debug.Print i & " shapes removed"
Set srBis = sr.BreakApartEx
Set sGr = srBis.Group
sGr.Name = "Whatever"
I think you can also can improve the solution. the created dimensions group to be moved at the exactly necesary scale... I would measure the all shapes dimension, temporarily removing the new create group and I will try scalling it against the shapes dimensions there where you need to move it...