I want tag numbers in shape's center,zhe shaps is Irregular,now I tag numbers often out of zhe shaps, like this:
You can use a numbering macro. I used to use this on physically large objects. You will undoubtedly need to tweak it to make it work for your use. It finds the location to place the number by contouring the object to center, then finding the centre of the innermost contour. It then deletes the contour and places the label there.
The macro will only work for closed objects and I made sure all my objects were closed and fillable prior to running it. You will need to change the text size no doubt. I make to warranties about this, I haven't run it for years, and I dont even know if it will still work but it used to.
Public Sub NumberObjects() 'All objects must be closed and fillable. 'Weld all objects together then break apart.Delete all very small pieces 'Scale up to 200% 'Select all and run macro Dim s As Shape, sText As Shape, sh As Shape Dim nNumber As Integer Dim x As Double, y As Double Dim x1 As Double, y1 As Double, w1 As Double, h1 As Double Dim lr1 As Layer Set lr1 = ActiveDocument.Pages(1).CreateLayer("Labels") ' this section finds all very small objects and deletes them. For Each sh In ActiveLayer.FindShapes(Type:=cdrCurveShape) sh.GetBoundingBox x1, y1, w1, h1 If w1 + h1 < 0.01 Then sh.Delete Next sh nNumber = 1 For Each s In ActivePage.FindShapes(Type:=cdrCurveShape) GetObjectCenter s, x, y Set sText = ActiveLayer.CreateArtisticText(x, y, CStr(nNumber), Font:="Arial", Size:=24, Alignment:=cdrCenterAlignment) sText.AlignToPoint cdrAlignHCenter + cdrAlignVCenter, x, y nNumber = nNumber + 1 Next sEnd SubPrivate Sub GetObjectCenter(ByVal s As Shape, ByRef x As Double, ByRef y As Double) Dim effContour As Effect Dim sr As ShapeRange Dim srContourGroup As Shape Dim sx As Double, sy As Double Dim x2 As Double, y2 As Double, w2 As Double, h2 As Double s.GetBoundingBox x2, y2, w2, h2 Select Case s.IsOnShape(x2 + w2 / 2, y2 + h2 / 2) Case cdrOutsideShape, cdrOnMarginOfShape Set effContour = s.CreateContour(cdrContourToCenter, 0.01) Set sr = effContour.Separate() Set srContourGroup = sr(1) ' "First" shape in the contour group will be the innermost step srContourGroup.Shapes(1).GetBoundingBox x, y, sx, sy x = x + sx / 2 y = y + sy / 2 srContourGroup.Delete Case cdrInsideShape x = x2 + w2 / 2 y = y2 + h2 / 2 End SelectEnd Sub
Hi Hywell
I was intrigued. I optimized the code:
I put into an attached GMS (in ZIP)
and made an icon
Problem with the forum I think, clicking the link ends up with 'page no longer exists.....'
I'm not sure who wrote that macro Jeff, it certainly wasn't me , I dont have the skills. The idea to contour to find the object centre was a very good idea since just using the object centre would often place the label outside the object path.
I don't use it now, its often just quicker to manually use a pen!!