[posetitel]

Вопрос про создание блока с атрибутом на VBA.
Атрибут в блока добавляется, но когда применяю команду выровнять текс по центру, точка вставки атрибута смещается в точку вставки блока, а нужно чтобы точка вставки атрибута осталась где и была, просто текст выравнивался не как по умолчанию влево, а по центру. Я даже принудительно пытался дополнительно задать точку вставки атрибута после выравнивания текста, все равно не помогает. Как сделать выравнивание текста атрибута без смещения точки вставки?

Код:

[Выделить все]

 Sub CreateAdjacencyMatrixFromAutoCAD()
    Dim plinePoint(0 To 9) As Double
    Dim plineCenterPoint1(0 To 3) As Double
    Dim plineCenterPoint2(0 To 3) As Double
    Dim pline As AcadLWPolyline
    Dim blockName As String
    Dim blockDef As Object
    Dim attributeValue As String
    Dim attributeDef As AcadAttribute
    Dim basePoint(0 To 2) As Double
    Dim insertionPoint(0 To 2) As Double
    Dim attPoint(0 To 2) As Double
    Dim newBlock As AcadBlock
    
    plinePoint(0) = -40
    plinePoint(1) = 0
    plinePoint(2) = 40
    plinePoint(3) = 0
    plinePoint(4) = 40
    plinePoint(5) = 50
    plinePoint(6) = -40
    plinePoint(7) = 50
    plinePoint(8) = -40
    plinePoint(9) = 0
    attributeValue = "Текст_для_теста"
    blockName = "Блок_для_теста"
    
    ' проверка наличия блока в чертеже
    Call BlockExists(blockName)
   
    Set newBlock = ThisDrawing.Blocks.Add(basePoint, blockName)
    Set pline = newBlock.AddLightWeightPolyline(plinePoint)
    Dim attributeParam As Integer
    attributeParam = 0
    attPoint(0) = 20
    attPoint(1) = 20
    attPoint(2) = 20
    Set attributeDef = newBlock.AddAttribute(2.5, attributeParam, "Описание_аттрибута", attPoint, "Tag1", attributeValue)
    ' строчку ниже можно закомментировать
    attributeDef.Alignment = acAlignmentMiddleCenter  ' Горизонтальное выравнивание по центру
    attributeDef.insertionPoint = attPoint
    attributeDef.Update
    insertionPoint(0) = 10
    insertionPoint(1) = 10
    insertionPoint(2) = 10
    ThisDrawing.ModelSpace.InsertBlock insertionPoint, blockName, 1#, 1#, 1#, 0#
    Set attributeDef = Nothing
    Set blockDef = Nothing
    Set acadDoc = Nothing
    Set acadApp = Nothing
End Sub

[Кулик Алексей aka kpblc]

Проверяй TextAlignmentPoint

[posetitel]

Спасибо. Тему можно и закрывать )