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