[Владимир_М]

Вопрос весь на картинках. Макрос создает блок, внутри которого добавляется размер дуги.
Результат на первой картинке. Размер дуги, как видно, слепился в одну точку. Казалось бы неправильно заданы точки. Но если разбить блок, то все встает на свои места как и предполагалось в коде. Разбитый блок - вторая картинка. Т. е. получается вся геометрия задана правильно.
Кто знает, что это за напасть такая?

[Boxa]

А можно сам файл выложить? Гадать по картинкам не очень интересно и продуктивно...

[swell{d}]

Регенерировать может нужно?

[Владимир_М]

Вот файл


Регенерация не помогает.

[Boxa]

Есть подозрение, что Вы не задаете точку вставки текста размера и он улетает в 0,0,0 системы координат блока...

[Владимир_М]

Да и у меня подозрение, что все 4 точки в 0,0,0. Но, вроде, все точки заданы.. Как их еще задавать?
Тем более линейные размеры нормально рисуются в том же блоке...

Код:

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

Dim location(0 To 2) As Double
Set layerObj = ThisDrawing.Layers.Item("Размеры")
ThisDrawing.ActiveLayer = layerObj
'размер хвостика
Dim dimObja As AcadDimAligned
point1(0) = pn(0): point1(1) = pn(1)
point2(0) = pn(2): point2(1) = pn(3)
location(0) = point1(0) + 1: location(1) = point1(1) - 8 * 10 / m
Set dimObja = blockObj.AddDimAligned(point2, point1, location)

'размер дуги
    Dim center(0 To 2) As Double
    center(0) = pn(2): center(1) = pn(1) + r_zag / m: center(2) = 0#
    Dim stPoint(0 To 2) As Double
    stPoint(0) = center(0): stPoint(1) = pn(1): stPoint(2) = 0#
    Dim EndPoint(0 To 2) As Double
    EndPoint(0) = center(0): EndPoint(1) = pn(5): EndPoint(2) = 0#
    
    Dim ptArcPoint(2) As Double
    ptArcPoint(0) = center(0) - 8 * 10 / m - r_zag / m: ptArcPoint(1) = center(1): ptArcPoint(2) = 0#
    
    Dim oAcadDimArcLength As AcadDimArcLength
    Set oAcadDimArcLength = blockObj.AddDimArc(center, stPoint, EndPoint, ptArcPoint)

[swell{d}]

http://vbamodel.narod.ru/AutoCAD/ex_adddimangular.htm

[Boxa]

Без всего кода несколько не удобно, но вот эта строчка смущает
EndPoint(1) = pn(5) ИМХО, там что то типа pn(1) + 2*r_zag / m должно быть

И еще, зачем вы столько новых сущностей и точек на вводили? из за этого и путаница

Код:

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

Dim location(0 To 2) As Double
Set layerObj = ThisDrawing.Layers.Item("Размеры")
ThisDrawing.ActiveLayer = layerObj
'размер хвостика
Dim dimObja As AcadDimAligned
point1(0) = pn(0)
point1(1) = pn(1)

point2(0) = pn(2)
point2(1) = pn(3)

location(0) = pn(0) + 1
location(1) = pn(1) - 8 * 10 / m

Set dimObja = blockObj.AddDimAligned(point2, point1, location)

'размер дуги
    Dim center(0 To 2) As Double
    center(0) = pn(2)
    center(1) = pn(3) + r_zag / m
    center(2) = 0#
    
    Dim stPoint(0 To 2) As Double
    stPoint(0) = pn(2)
    stPoint(1) = pn(3)
    stPoint(2) = 0#
    
    Dim EndPoint(0 To 2) As Double
    EndPoint(0) = pn(2)
    EndPoint(1) = pn(3) + 2 * r_zag / m
    EndPoint(2) = 0#
    
    Dim ptArcPoint(2) As Double
    ptArcPoint(0) = pn(2) - 8 * 10 / m - r_zag / m
    ptArcPoint(1) = center(1)
    ptArcPoint(2) = 0#
    
    Dim oAcadDimArcLength As AcadDimArcLength
    Set oAcadDimArcLength = blockObj.AddDimArc(center, stPoint, EndPoint, ptArcPoint)

[Владимир_М]

Сообщение от Boxa И еще, зачем вы столько новых сущностей и точек на вводили? из за этого и путаница

Каких именно сущностей? и с точками? не очень понял... это просто немного переделанные примеры из справки VBA-acad по отрисовке размеров... наверное, в задании точек чуток здесь можно соптимизировать, но навряд ли от этого результат изменится...
Тот код, что Вы выдали, он у Вас нормально сработал? У меня и с Вашим кодом получилось все то же самое, что и и было... (у меня Асаd 2016)

Взял отдельный пример из справки Sub Example_AddDimArc(). Все естественно работает. Но при замене ThisDrawing.ModelSpace на ThisDrawing.Blocks происходит то же, что и в моём случае. Т. е. причина именно в этом.
Но что делать? так и непонятно...

[Boxa]

1. Код этот не я выдал, это Ваш же код, только оформленный несколько иначе.
2. И как я мог Ваш код попробовать, если Вы опубликовали только фрагмент?
3. Все оказалось несколько сложнее, но Поиск никто не отменял : http://adndevblog.typepad.com/autoca...using-vba.html

По ссылке не совсем рабочий код, вот такой отработал правильно и корректно в autocad 2014 x64

Код:

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

Sub Example_AddDimArc()
  
    'Start point
    Dim ptArcStPoint(2) As Double
    ptArcStPoint(0) = 0
    ptArcStPoint(1) = -10
    ptArcStPoint(2) = 0
    
    'End point
    Dim ptArcEnPoint(2) As Double
    ptArcEnPoint(0) = 0
    ptArcEnPoint(1) = 10
    ptArcEnPoint(2) = 0
    
    'Center point
    Dim ptArcCPoint(2) As Double
    ptArcCPoint(0) = 0
    ptArcCPoint(1) = 0
    ptArcCPoint(2) = 0
    
    'Arc point
    Dim ptArcPoint(2) As Double
    ptArcPoint(0) = 120
    ptArcPoint(1) = 10
    
    Dim oMS As AcadModelSpace
    Set oMS = ThisDrawing.ModelSpace
    Dim oAcadDimArcLength As AcadDimArcLength
    Set oAcadDimArcLength = oMS.AddDimArc(ptArcCPoint, ptArcStPoint, ptArcEnPoint, ptArcPoint)
    
    ' Create the block
    Dim blockObj As AcadBlock
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0#
    insertionPnt(1) = 0#
    insertionPnt(2) = 0#
    Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "CircleBlock")
    
    ' Insert block
    Dim blockRefObj As AcadBlockReference
    insertionPnt(0) = 2
    insertionPnt(1) = 2
    insertionPnt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, "CircleBlock", 1#, 1#, 1#, 0)
    
    'Copy dim to Block
    Dim objCollection(0) As Object
    Set objCollection(0) = oAcadDimArcLength
    Dim retObjects As Variant
    retObjects = ThisDrawing.CopyObjects(objCollection, blockObj)
 
    oAcadDimArcLength.Delete
    blockObj = Nothing
    oAcadDimArcLength = Nothing

End Sub

ЗЫ.
Интересно то, что и в nanoCAD созданном на основе Tiega, эта же ошибка присутствует

[Владимир_М]

Сообщение от Boxa По ссылке не совсем рабочий код, вот такой отработал правильно и корректно

и у меня тоже! Boxa, большое спасибо!