• Dimas
  • Восстановленный участник
  • На форуме с 25 июля 2006г.
  • Сообщений: 48
  • Спасибо: 0

Тема: текст по центру полигона

Есть код получения area полигона. Цель вставить текст в контур выделенного полигона (в средину). Короче как высчитать координаты этой вставки.

  • fixo
  • Восстановленный участник
  • На форуме с 3 июля 2008г.
  • Сообщений: 217
  • Спасибо: 0

Re: текст по центру полигона

> Dimas
Вот пример для отдельного полигона, думаю тебе
будет легко переделать для целого набора
Будет работать только для облегченных полилиний

Option Explicit
Sub PolygonCenter()
    Dim objEnt As AcadEntity
    Dim plineObj As AcadLWPolyline
    Dim dblPlineCenter As Variant
    Dim basePnt As Variant
    Dim dblArea As Double
    Dim dblHeight As Double
    Dim conPt(2) As Double
    ThisDrawing.Utility.GetEntity objEnt, basePnt, "Select the polygon"
    If Not TypeOf objEnt Is AcadLWPolyline Then
        Exit Sub
    End If
    dblHeight = ThisDrawing.GetVariable("TEXTSIZE")
    dblPlineCenter = EntityCentroid(objEnt)
    Set plineObj = objEnt
    dblArea = plineObj.Area
    conPt(0) = dblPlineCenter(0): conPt(1) = dblPlineCenter(1): conPt(2) = plineObj.Elevation
    Dim wcsPt As Variant
    wcsPt = ThisDrawing.Utility.TranslateCoordinates(conPt, acUCS, acWorld, False)
    AddTextEx Format(CStr(dblArea), "#0.000"), wcsPt, dblHeight, 1
End Sub
Public Sub AddTextEx(txtStr As String, insPt As Variant, txtHeight As Double, Optional alignMode As Integer = 0)
    Dim objSpace As AcadBlock
    Dim objText As AcadText
    If ThisDrawing.ActiveSpace = acModelSpace Then
        Set objSpace = ThisDrawing.ModelSpace
    Else
        Set objSpace = ThisDrawing.PaperSpace
    End If
    On Error GoTo ErrorHandler
    Set objText = objSpace.AddText(txtStr, insPt, txtHeight)
    If alignMode Then
        objText.Alignment = alignMode
        objText.TextAlignmentPoint = insPt
    End If
    objText.Update
ErrorHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
End Sub
Private Function EntityCentroid(Entity As AcadEntity) As Double()
' This will get you the center of a closed polyline.
' http://discussion.autodesk.com/thread.jspa?messageID=2140876
    Dim EntityArray(0) As AcadEntity, RegionList As Variant
    Set EntityArray(0) = Entity
    RegionList = ThisDrawing.ModelSpace.AddRegion(EntityArray)
    EntityCentroid = RegionList(0).Centroid
    RegionList(0).Delete
End Function

~'J'~

  • Dimas
  • Восстановленный участник
  • На форуме с 25 июля 2006г.
  • Сообщений: 48
  • Спасибо: 0

Re: текст по центру полигона

Вот для группы полигонов. Выборка из набора.

Sub area_pline_center()
Dim Sel As AcadSelectionSet
    Dim TextObj As AcadText
    Dim textString As String
    Dim insertionPoint As Variant
    Dim height As Double
    Dim conPt(2) As Double
    Dim wcsPt As Variant
    Dim VarPnt(2) As Double
height = 2
Set Sel = ThisDrawing.SelectionSets.Add("Pline")
Sel.SelectOnScreen
Dim Entry As AcadEntity
  For Each Entry In Sel
    insertionPoint = EntityCentroid(Entry)
    dblArea = Entry.Area
    VarPnt(0) = insertionPoint(0): VarPnt(1) = insertionPoint(1): VarPnt(2) = 0
wcsPt = ThisDrawing.Utility.TranslateCoordinates(VarPnt, acUCS, acWorld, False)
    AddTextEx Format(CStr(dblArea), "#0.0"), wcsPt, height, 1
    Entry.Update
  Next Entry
Sel.Delete
End Sub
Public Sub AddTextEx(txtStr As String, insPt As Variant, txtHeight As Double, Optional alignMode As Integer = 0)
    Dim objSpace As AcadBlock
    Dim TextObj As AcadText
    If ThisDrawing.ActiveSpace = acModelSpace Then
        Set objSpace = ThisDrawing.ModelSpace
    Else
        Set objSpace = ThisDrawing.PaperSpace
    End If
    On Error GoTo ErrorHandler
    Set TextObj = objSpace.AddText(txtStr, insPt, txtHeight)
    If alignMode Then
        TextObj.Alignment = alignMode
        TextObj.TextAlignmentPoint = insPt
    End If
    TextObj.Update
ErrorHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
End Sub
Private Function EntityCentroid(Entry As AcadEntity) As Double()
    Dim EntityArray(0) As AcadEntity, RegionList As Variant
    Set EntityArray(0) = Entry
    RegionList = ThisDrawing.ModelSpace.AddRegion(EntityArray)
    EntityCentroid = RegionList(0).Centroid
    RegionList(0).Delete
End Function