# 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

• 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

• 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

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
```

also, is it possible to measure without breaking apart the text?

Thank you Shelby