Hello,
I have to fit numbers to several shape-s like this. I use Fit text to frame method but sometimes it results like this: (the number goes outside to the shape..)
Good quality image: http://www.kepfeltoltes.eu/images/2022/01/23/127111.png
I would need an automatic method what makes the positioning/ resizing of the numbers 100% correct.
The numbering is a part of a macro which I'm using to order the correct numbers...
BTW: I was trying to make the text frame (margin) larger but there is no option for it.
Thanks for everyone who wants to help me!
Zoltán
Hello Taras,
The following line is not good as SRgrp stays 'Nothing' after executing this line:
Set SRgrp = eff1.Separate
And then the following line gives exception as the previous line resulted SRgrp to be 'Nothing'.
I am really appreciate your kind help, - I'll try to solve it today, but if you have any idea, please let me know.
Thank you very much!
Note that you must first click on the text shape then on the frame (+Shift)After thet run Macro1Just change this param
R = s1.SizeHeight / 5 ' Contour offsetmake 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 = XsT.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 RSub Macro1()Dim SR As ShapeRange, sT As Shape, s1 As Shape, R As DoubleDim 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 offset5 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.DeleteEnd 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 IntegerActiveDocument.Unit = cdrMillimeter
Optimization = TrueSet fcsr = ActivePage.Shapes.FindShapes("CIdx") 'Object of the numberFor i = 1 To fcsr.Count ContourInMk fcsr(i).Text.Frame.Container, fcsr(i) 'the container is the shape around the numberNext iOptimization = FalseActiveWindow.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 distanceR = 0.1
start:'Create contour inside to the frameSet eff1 = sF.CreateContour(cdrContourInside, R)Set SRgrp = eff1.SeparateIf SRgrp Is Nothing Then Exit FunctionSet s = SRgrp.Shapes.Firsts.ConvertToCurves 'Temporary shape
'Select the biggest part of the temporary shapeIf 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 nElse biggestArea = 1End If
'Repeat if the biggest area is more than 1If s.Curve.SubPaths(biggestArea).Area > 1 Then R = R + (s.Curve.SubPaths(biggestArea).Area / s.Curve.SubPaths(biggestArea).Length) / 2 s.Delete GoTo startEnd If
'Set the position of the text objectOn Error Resume NextsT.ConvertToCurvessT.CenterX = s.Curve.SubPaths(biggestArea).BoundingBox.CenterXsT.CenterY = s.Curve.SubPaths(biggestArea).BoundingBox.CenterY
'Delete the temporary shapes.DeleteEnd Function