Hi,
How to achieve this with macro, measure the distance between objects.
we can add it manually, but sometimes there are many letters and it is taking time, hehe. Maybe someone knows how to do it with macro.Thanks
Hello Robby,
I will get this started, this will not be a complete answer as you will see.
Sub MutliDimensions() Dim srSelection As ShapeRange Dim i As Long Dim x As Double, y As Double, w As Double, h As Double Dim pt1 As SnapPoint, pt2 As SnapPoint Dim s As Shape, sDim As Shape Set srSelection = ActiveSelectionRange.ReverseRange For i = 1 To srSelection.Shapes.Count srSelection(i).GetBoundingBox x, y, w, h Set pt1 = CreateSnapPoint(x + w, y) If srSelection(i + 1) Is Nothing Then Exit Sub srSelection(i + 1).GetBoundingBox x, y, w, h Set pt2 = CreateSnapPoint(x, y) Set sDim = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pt1, pt2, True, , y - 0.5, cdrDimensionStyleDecimal, Units:=cdrDimensionUnitCM) Next i End Sub
Since we do not know what each shape will be, I am looking at the BoundingBox of the shape. Also you need to shift select each shapes from left to right to make this work.
So here is an example. If I select the rectangle, then shift select the ellipse and then shift select the star I would get this.
But if I selected the star first, then shift select the ellipse, then shift select the rectangle I would get this.
So selection order matters. :-)
You will also see this code only works left to right, it will not do your top to bottom example. Also, it will not work for text unless you break your word into indivual characters.
See what you can do to make it better. :-)
Happy coding,
-Shelby
Hi Shelby,
Thank you very much for the code. I've tried to make it vertical (top to bottom) by first selecting the topmost object.
Sub MutliDimensionsVert() Dim srSelection As ShapeRange Dim i As Long Dim x As Double, y As Double, w As Double, h As Double Dim pt1 As SnapPoint, pt2 As SnapPoint Dim s As Shape, sDim As Shape Set srSelection = ActiveSelectionRange.ReverseRange For i = 1 To srSelection.Shapes.Count srSelection(i).GetBoundingBox x, y, w, h Set pt1 = CreateSnapPoint(x + w, y) If srSelection(i + 1) Is Nothing Then Exit Sub srSelection(i + 1).GetBoundingBox x, y, w, h Set pt2 = CreateSnapPoint(x + w, y + h) Set sDim = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pt1, pt2, True, , , cdrDimensionStyleDecimal, Units:=cdrDimensionUnitCM) sDim.dimension.TextShape.SetPosition x + w + 1, y + sDimx / 2 Next iEnd Sub
(sorry plainly pasted the code, because i don't know to make it like yours, hehe). Also, i don't know to make in one code that checks if the object is horizontal or vertical.
I tried to select it with the selection box, but the order of objects I think is following the order of object position in the layer. I'm thinking of a workaround, but I cannot implement it into code, since I don't know what to write.
for horizontal.
for vertical, same as horizontal but with y value.
as for the text object, I don't mind to break apart it into individual characters, if it can do it, that will be a great addition. hehe
Robby,
Very well done! One little change, when you are setting the Text for the Dimension you are using a variable that is unassigned "sDimx" so it has no value. I would just set the test position at the same time I create the dimension.
You are also correct, that if you use a selection box to select your shapes that they will be put in stacking order. So unless you draw everything in order you cannot count on them being top to bottom. This can be addressed by adding a sort to the ShapeRange.
In my example below you will se that I removed your TextShape.SetPosition line and set the posting of the test in the CreateLinearDimension line.
I have also added a very simple sort to the ShapeRange that puts the ShapeRange in order from top to bottom.
Sub MutliDimensionsVert() Dim srSelection As ShapeRange Dim i As Long Dim x As Double, y As Double, w As Double, h As Double Dim pt1 As SnapPoint, pt2 As SnapPoint Dim s As Shape, sDim As Shape Set srSelection = ActiveSelectionRange 'Sort from top to bottom srSelection.Sort "@shape1.Top > @shape2.Top" For i = 1 To srSelection.Shapes.Count srSelection(i).GetBoundingBox x, y, w, h Set pt1 = CreateSnapPoint(x + w, y) If srSelection(i + 1) Is Nothing Then Exit Sub srSelection(i + 1).GetBoundingBox x, y, w, h Set pt2 = CreateSnapPoint(x + w, y + h) Set sDim = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pt1, pt2, True, x + w + 1, , cdrDimensionStyleDecimal, Units:=cdrDimensionUnitCM) Next i End Sub
Yes a text object can be broken into indivual characters via code. :-) See if you can figure out how.
Shelby,
Wow, the "very simple" sort to ShapeRange is a magic code.
Here I tried to combine it with code that I found online here. also, I have changed the snap point to the top of the object so we can see the line along the object (from where to where the distance is measured)
I'm sorry for the messy code setup hehe.
Sub MultiDimensionsTextH() Dim sT As Shape Dim srSelectionT As ShapeRange Dim srStateBefore As ShapeRange Dim srStateAfter As ShapeRange Set srSelectionT = ActiveSelectionRange 'Get all the text objects before the operation Set srStateBefore = ActivePage.FindShapes(Type:=cdrTextShape) For Each sT In srSelectionT If sT.Type = cdrTextShape Then If sT.Text.Type = cdrArtisticText Then sT.breakapart 'If s.Text.Story.Lines.Count > 1 Then s.breakapart End If Next sT 'And now after the operation Set srStateAfter = ActivePage.FindShapes(Type:=cdrTextShape) srStateAfter.RemoveRange srStateBefore srStateAfter.AddToSelection Dim NewSelection As New ShapeRange Set NewSelection = ActiveSelectionRange Dim srSelection As ShapeRange Dim i As Long Dim x As Double, y As Double, w As Double, h As Double Dim pt1 As SnapPoint, pt2 As SnapPoint Dim s As Shape, sDim As Shape Set srSelection = ActiveSelectionRange.ReverseRange 'Sort from left to right srSelection.Sort "@shape1.Left > @shape2.Left" For i = 1 To srSelection.Shapes.Count srSelection(i).GetBoundingBox x, y, w, h Set pt1 = CreateSnapPoint(x, y + h) If srSelection(i + 1) Is Nothing Then Exit Sub srSelection(i + 1).GetBoundingBox x, y, w, h Set pt2 = CreateSnapPoint(x + w, y + h) Set sDim = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pt1, pt2, True, , y - 0.5, cdrDimensionStyleDecimal, Units:=cdrDimensionUnitCM) Next i End Sub
this code is only working with word text, once the text has been breakaparted into individual characters, the code is not working. But, with a non-text object, this code is working.
I am thinking to add Force Horizontal Text when using vertical measurement, I tried adding
HorizontalText:=True into CreateLinearDimension, but no success.
Also, I have tried adding an optimizer, but it breaks the code (i think)
--- Optimization = True ActiveDocument.BeginCommandGroup "BuatLis120Comb" EventsEnabled = False ActiveDocument.SaveSettings ActiveDocument.PreserveSelection = False On Error GoTo ErrHandler --- Code Goes Here --- ExitSub: ActiveDocument.PreserveSelection = True ActiveDocument.RestoreSettings EventsEnabled = True Optimization = False ActiveDocument.ClearSelection ActiveWindow.Refresh Application.Refresh ActiveDocument.EndCommandGroup Exit Sub ErrHandler: MsgBox "Error occured: " & Err.Description Resume ExitSub s.AddToSelection
also, is it possible to measure without breaking apart the text?
Thank you Shelby