How can I tag numbers in every shaps center with gms?

I want tag numbers in shape's center,zhe shaps is Irregular,now I tag numbers often out of zhe shaps, like this:

Parents
  • 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 s
    End Sub

    Private 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 Select
    End Sub

Reply Children
No Data