Measure distance between objects

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

Parents
No Data
Reply
  • 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

Children