Macro for automatic callout maker


i've got a problem with a macro.

I have old cgm data with old callouts from another designer tool.

The old callouts are know divided into curves, ellipses and text. My goal is to transform it into a new callout.

So my idea is so get the coordinates from the text as the starting point and the coordinate from the ellipses as the the endpoint and make a new callout. The problem is, i can't get the coordinates from the text. 

My macro looks like this at the moment:

Sub Macro1()
ActiveDocument.Unit = cdrMillimeter
Dim sh As Shape
Dim shs As Shapes
Dim s1 As Shape
Dim s2 As Shape
Dim OrigSelection As ShapeRange

Set shs = ActiveSelection.Shapes()

With ActiveSelection.Ellipse
Ex = .CenterX
Ey = .CenterY
End With

With ActiveSelection.Text
Tx = .CenterX
Ty = .CenterY
End With

MsgBox Tx

For Each sh In shs.FindShapes(, cdrTextShape)
Set s1 = ActiveLayer.CreateCustomShape("Callout", sh.Text.Story, 0, 0.07874, Array(Ex, Ey), Array(128.25, 53.74), 0#, Nothing, 0, 0, False)
Set s2 = s1.Custom.TextShape
Dim Callout1 As ShapeRange
Set Callout1 = ActiveDocument.CreateShapeRangeFromArray(s2, s1)
Callout1.SetOutlinePropertiesEx 0.013776, OutlineStyles(0), CreateRGBColor(0, 0, 0), ArrowHeads(90), ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineRoundLineCaps, cdrOutlineRoundLineJoin, 0#, 100, MiterLimit:=5#, Justification:=cdrOutlineJustificationMiddle
Next sh

End Sub

Maybe you have an idea.
No Data
  • What do you name „text coordinates”? Height, Width, CenterX, CenterY, text.Story, font, font size, Top, Left etc.?

    I can see part of them in the code example...

    Can you detail a little your last sentence which looks to you being important to be done?

    Can you bring here the shape you try to reproduce?