Fit text inside to an object 100%

Note that you must first click on the text shape then on the frame (+Shift)
After thet run Macro1

Just change this param

R = s1.SizeHeight / 5  ' Contour offset

make R = 1 then R = 2 .....  to understand 

Taras

Yes, the value of R was too high so I changed '/5' to '/25' to make it smaller.

Now this part is working and there is no exception.

From here the problem is that the following code don't set anything

sT.CenterX = X
sT.CenterY = Y

I mean, after executing these two lines, both CenterX and Y values remain as they were.

The other problem is that the shape of the objectcountour has very similar size to the original shape...

You can see in the following example: (I moved the countour next to the original shape to illustrate)

calculate the parameter R

Sub Macro1()
Dim SR As ShapeRange, sT As Shape, s1 As Shape, R As Double
Dim X As Double, Y As Double

ActiveDocument.Unit = cdrMillimeter

Set SR = ActiveSelectionRange
Set sT = SR.Shapes.Last ' text Shape
Set s1 = SR.Shapes.First ' Frame shape

R = 1 's1.SizeHeight / 5 ' Contour offset
5
ContourInMk s1, R
If s.Curve.Area > 20 Then
R = R + 1
s.Delete
GoTo 5
End If

X = s.CenterX
Y = s.CenterY

sT.CenterX = X
sT.CenterY = Y

s.Delete
End Sub

Hello!

Thank you for your help, I managed to do it with some modification.

The final code is:

Sub TextCorrectionSub()
Dim fcsr As ShapeRange, i As Integer
ActiveDocument.Unit = cdrMillimeter

Optimization = True
Set fcsr = ActivePage.Shapes.FindShapes("CIdx") 'Object of the number
For i = 1 To fcsr.Count
   ContourInMk fcsr(i).Text.Frame.Container, fcsr(i) 'the container is the shape around the number
Next i
Optimization = False
ActiveWindow.Refresh

End Sub

Private Function ContourInMk(sF As Shape, sT As Shape)
Dim eff1 As Effect, SRgrp As ShapeRange, R As Double, biggestAreaSize As Double, biggestArea As Integer

'Set the base distance
R = 0.1

start:
'Create contour inside to the frame
Set eff1 = sF.CreateContour(cdrContourInside, R)
Set SRgrp = eff1.Separate
If SRgrp Is Nothing Then Exit Function
Set s = SRgrp.Shapes.First
s.ConvertToCurves 'Temporary shape

'Select the biggest part of the temporary shape
If s.Curve.SubPaths.Count > 1 Then
   biggestAreaSize = 0
   For n = 1 To s.Curve.SubPaths.Count
      If s.Curve.SubPaths(n).Area > biggestAreaSize Then
         biggestAreaSize = s.Curve.SubPaths(n).Area
         biggestArea = n
      End If
   Next n
Else
   biggestArea = 1
End If

'Repeat if the biggest area is more than 1
If s.Curve.SubPaths(biggestArea).Area > 1 Then
   R = R + (s.Curve.SubPaths(biggestArea).Area / s.Curve.SubPaths(biggestArea).Length) / 2
   s.Delete
   GoTo start
End If

'Set the position of the text object
On Error Resume Next
sT.ConvertToCurves
sT.CenterX = s.Curve.SubPaths(biggestArea).BoundingBox.CenterX
sT.CenterY = s.Curve.SubPaths(biggestArea).BoundingBox.CenterY

'Delete the temporary shape
s.Delete
End Function