Программное создание мультивыноски

Makswell · 11.12.2008, 16:15

Всем привет.
Собственно требуется создать программно мультивыноску. Не знаю как?
У объекта ModelSpace есть метод AddMLeader.
У Полещука описание этого метода отсутствует.
Единственная инфа, которую нашёл, оказалась в справке:

Цитата:

AddMLeader method

Signature

RetVal = object.AddMLeader(pointsArray, leaderLineIndex)

Object

ModelSpace Collection, PaperSpace Collection, Block
The object or objects this method applies to.

pointsArray

Variant (three-element array of Doubles); input-only
The array of 3D WCS coordinates specifying the leader. You must provide at least two point to define the leader. The third point is optional.

leaderLineIndex

Long; input-only
Input index of the mleader cluster.

RetVal

MLeader object
The newly created MLeader object.

И пример оттуда же:

Цитата:

Sub Example_AddMLeader()
Dim oML As AcadMLeader
Dim points(0 To 14) As Double

' Define the leader points
points(0) = 1: points(1) = 1: points(2) = 0
points(3) = 1: points(4) = 2: points(5) = 0
points(6) = 2: points(7) = 2: points(8) = 0
points(9) = 3: points(10) = 2: points(11) = 0
points(12) = 4: points(13) = 4: points(14) = 0
Dim i As Long
Set oML = ThisDrawing.ModelSpace.AddMLeader(points, i)

End Sub

Пока ничего не понятно. Может кто расшифрует этот код применительно к лиспу, т.к. VBA я не знаю.

ShaggyDoc · 11.12.2008, 17:44

Мультивыноска через LISP создается функцией

Код:

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

 
(vla-addmleader  активное_рабочее_пространство массив_точек_выноски  0)

Здесь самое сложное - создать safe-array из координат точек. Для простенькой односегментной выноски масив можно сделать примерно так:

Код:

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

(defun ru-mleader-coords-from-list (list_points / n pt pt_array)
(setq pt_array
             (vlax-make-safearray vlax-vbdouble (cons 1 (* 3 (length list_points))))
            n 0
      )
      (while (< n (length list_points))
        (setq pt (nth n list_points))
        (vlax-safearray-put-element pt_array (+ (* n 3) 1) (car pt))
        (vlax-safearray-put-element pt_array (+ (* n 3) 2) (cadr pt))
        (vlax-safearray-put-element pt_array (+ (* n 3) 3) (caddr pt))
        (setq n (1+ n))
      )
  pt_array
 )

Можно и более изячно, но так понятней.
Можно мультивыноску и добавить командой, например так (для двух точек):

Код:

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

 
(vl-cmdf "_.MLEADER"
      (trans (car list_points) 0 1)
       (trans (cadr list_points) 0 1)
       ""
)

Здесь list_points - обычный список координат из двух элементов.

После того, как объект мультивыноски создан, для него надо установить всё то множество свойств, чтобы он выглядел правильно. И, конечно, установить главное свойство - textstring.

Все эти действия спрятать в низкоуровневые функции, а на самом верху сделать 1-2 "конечных" функции, в которые передавать простые аргументы, например строку над выноской и под выноской.

Makswell · 12.12.2008, 08:26

Спасибо большое.
Ещё один момент. Что значит последний аргумент метода AddMLeader? Который в Вашем коде равен 0.

ShaggyDoc · 12.12.2008, 09:40

Надо научиться справкой по объектам. Делать надо так:
1. В Vlide вызвать справку
2. Выбрать ActiveX and VBA Reference
3. Выбрать в дереве Objects
4. Выбрать нужный объект, например Mleader object
5. Щелкнуть по нему и посмотреть. Причитать общее описание. Там есть ссылка

Цитата:

To create an mleader, use the AddMLeader method. To edit or query a leader, use the following methods and properties:

Это значит - сначала добавить объект, а потом воспользоваться его свойствами и методами.

Посмотреть Methods и Properties. Но сначала перейти на AddMleader. Там есть описание в стиле VBA

Код:

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

 
Signature 
RetVal = object.AddMLeader(pointsArray, leaderLineIndex) Object

ModelSpace Collection, PaperSpace Collection, Block
The object or objects this method applies to. pointsArray

Variant (three-element array of Doubles); input-only
The array of 3D WCS coordinates specifying the leader. You must provide at least two point to define the leader. The third point is optional. leaderLineIndex

Long; input-only
Input index of the mleader cluster. RetVal
MLeader object
The newly created MLeader object.

Если перевести его на LISP, то это означает:
1. Должна быть функция с именем vla-AddMleader.
2. Первым аргументом этой функции должно быть рабочее пространство, куда добавлять объект. В сигнатуре VBA нет такого аргумента, но есть object.AddMleader и перечень, чем может быть этот object.
3. Второй аргумент pointsArray (не LISP-список). Как его сделать я показал.
4. Третий загадочный аргумент - leaderLineIndex. Вспоминаем, что у мультивыноски может быть несколько выносных линий. Мы, для начала, делаем одну, а её индекс (номер) как раз и будет 0.
5. И возвратить эта функция должна созданный объект. Его надо запомнить в переменной, чтобы потом применять к нему методы или устанавливать свойства.
Например, чтобы занести текст, надо

Код:

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

(setq mleader_obj (vla-addmleader ...))

а потом где-то дальше

Код:

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

(vlax-put-property  mleader_obj 'textstring  "Это моя строка")

Имя свойства TextString мы нашли в перечне свойств. Можно было-бы и другой вариант написать

Код:

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

(vla-put-textstring mleader_obj  "Это моя строка")

Только на самом деле в надежных программах всё сложнее. Прежде чем установить свойство, надо проверить доступно ли оно. Да еще может и ошибка (по любым причинам) произойти при установке свойства. Поэтому лучше все это прятать в дополнительные функции, чтобы не повторять один и тот же код в разных программах.

Makswell · 12.12.2008, 10:33

Ок. Понятно.
Ещё раз спасибо.

Добавлено:
Просто "Input index of the mleader cluster" я переводил как "Ввести индекс кластера мультилинии"

Кулик Алексей aka kpblc · 13.12.2008, 00:37

ShaggyDoc, позволю себе немного уточнить: достаточно набрать в консоли запущенной VLIDE vla-addmleader и тут же нажать Ctrl+F1. В подавляющем большинстве случаев (кроме особо тяжелых) открывается справка с уже открытым указанным методом.

ShaggyDoc · 13.12.2008, 06:44

Да, конечно. Можно и так. Но для этого надо написать, то есть знать, что существует метод AddLeader, и к нему надо добавить vla-. Ctrl+F1 очень удобно, когда надо уточнить что-то по известной функции.

Я специально описал самый длительный путь. А до более коротких вариантов уже можно додуматься.

Кулик Алексей aka kpblc · 13.12.2008, 10:02

Я его нашел случайно

ShaggyDoc · 13.12.2008, 11:15

Ctrl+F1 в различных IDE обычно и вызывает справку по выделенному коду. А "более короткие" варианты - это просмотр веток Metods и Props, не заглядывая в Objects.

skkkk · 05.12.2010, 00:36

Подскажите, пожалуйста как при создании лиспом мультивыноски, задать в ее содержимом ЗНАЧЕНИЕ переменной, обозначенной в этом же лиспе

Код:

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

(defun c:ml (/ a b)

(setq a (getpoint "Укажите точку вставки  <Выход>: "))
(setq b (getreal "Введите размер уголка <Выход>: "))

(command "_mleader" a pause "_e" "0" "Уголок b")

Вот вместо "Уголок b" как вставить "Уголок 160", если на запрос значения "b" я ввожу "160"?

Кулик Алексей aka kpblc · 05.12.2010, 00:43

(command "_mleader" a pause "_e" "0" (strcat "Уголок " b))

skkkk · 05.12.2010, 01:11

Алексей, ком строка ругается

Цитата:

Введите текст: ; ошибка: неверный тип аргумента: stringp 160.0

И еще: там не надо установить точность, чтоб было просто 160?

Добавлено: разобрался... (setq b (getstring...

Кулик Алексей aka kpblc · 05.12.2010, 01:19

Конвертируй в строку. Либо через rtos, либо через itoa, либо через vl-princ-to-string, либо в местной библиотеке бери соответствующую функцию

skkkk · 14.12.2010, 21:08

Реально ли создать программно СТИЛЬ мультивыноски? Такой, как во вложении

Дима_ · 15.12.2010, 15:04

А в чем там сложность?

skkkk · 15.12.2010, 15:16

В том, что _mleaderstyle не запускается в прозрачном режиме, а vl я не знаю...

Vildar · 15.12.2010, 15:33

skkkk, стили мультивыносок хранятся в словаре ACAD_MLEADERSTYLE.
Там храняться объекты AcadMleaderStyle

Sub MLS()

Dim oDict As AcadDictionary
Set oDict = ThisDrawing.Dictionaries.Item("ACAD_MLEADERSTYLE")

Dim i As Long
For i = 0 To oDict.Count - 1
Dim oObj As AcadObject
Set oObj = oDict.Item(i)
If oObj.ObjectName = "AcDbMLeaderStyle" Then
Dim oMLS As AcadMLeaderStyle
Set oMLS = oObj
MsgBox "Name = " & oMLS.Name & vbCrLf & _
"Annotative = " & oMLS.Annotative & vbCrLf & _
"ContentType = " & oMLS.ContentType & vbCrLf & _
"LeaderLineType = " & oMLS.LeaderLineType, vbInformation, "MLeader Styles"
End If
Next i
Dim oNewMLS As AcadMLeaderStyle
Set oNewMLS = oDict.AddObject("TEST", "AcDbMLeaderStyle")

oNewMLS.LeaderLineType = acSplineLeader
Dim oCol As New AcadAcCmColor
oCol.ColorIndex = acBlue
oNewMLS.LeaderLineColor = oCol

Call ThisDrawing.SetVariable("CMLEADERSTYLE", "TEST")
Dim points(0 To 5) As Double
points(0) = 1: points(1) = 1: points(2) = 0
points(3) = 2: points(4) = 2: points(5) = 0
Dim oML As AcadMLeader
Set oML = ThisDrawing.ModelSpace.AddMLeader(points, i)
oML.TextString = "mleader created with " & vbCrLf & "style ""TEST"""

End Sub

VVA · 15.12.2010, 16:37

Цитата:

Сообщение от skkkk

В том, что _mleaderstyle не запускается в прозрачном режиме, а vl я не знаю...

Переделай под себя

Код:

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

(defun mip-mleader-style-create ( mleaderstylename dimblk / mldrdict newldrstyle textcolor leadercolor objcolor)
;;; Создание стиля выноски MIP
;;;   mleaderstylename - имя стиля
;;;   dimblk - имя блока на конце (см переменную DIMBLK, например _Dot) или nil - нет
;;; Возвращает указатель на объект созданного стиля
;;;; Пример:   (mip-mleader-style-create "Skkk" nil)
;;; Установить стиль текущим
;;; (setvar "CMLEADERSTYLE" (vla-get-name (mip-mleader-style-create "Skkk" nil)))  
   
;;; Проверка наличия стиля
;;;(setq mleaderstylename "MIP")
;;;  (if (and (getvar "CMLEADERSTYLE") ;;;Автокад поддерживает мультивыноски
;;;         (setq tb-dic(DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE"))
;;;	 (not (member (cons 3 (strcase mleaderstylename))(DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE"))))
;;;    (progn )
;;;    )
(or dimblk (setq dimblk "_None"))
(setq mldrdict (vla-item (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))) "ACAD_MLEADERSTYLE"))
(setq newldrstyle (vlax-invoke mldrdict 'addobject mleaderstylename "AcDbMLeaderStyle"))
(setq textcolor acByBlock) ;;;Цвет текста
(setq leadercolor acByBlock) ;;;Цвет выноски
(setq objcolor (vla-getinterfaceobject
(vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar "acadver") 1 2))
) ;_vla-getinterfaceobject
) ;_setq
(vla-put-ColorIndex objcolor textcolor)
(vla-put-TextColor newldrstyle objcolor)
(vla-put-ColorIndex objcolor leadercolor)
(vla-put-LeaderLineColor newldrstyle objcolor)
(if (not (tblobjname "block" dimblk))
       (progn
	 (setq textcolor (getvar "dimblk"))
         (if (VL-CATCH-ALL-ERROR-P(VL-CATCH-ALL-APPLY 'setvar (list "dimblk" dimblk)))
           (setvar "dimblk" (setq dimblk "_None"))
           )
	 (setvar "dimblk" (if (= textcolor "") "." textcolor))
	 )
       )  
(foreach item
(list
'("AlignSpace" 5.0)
'("Annotative" 0)
'("ArrowSize" 0.30) ;_Размер стрелки
(list "ArrowSymbol"  dimblk)
'("BitFlags" 0)
'("BlockConnectionType" 0)
'("BlockRotation" 0.0)
'("BlockScale" 1.0)
'("BreakSize" 0.125)
'("ContentType" 2)
'("Description"  "Стиль УП Минскинжпроект")
'("DoglegLength" 0.3)
'("DrawLeaderOrderType" 0)
'("DrawMLeaderOrderType" 1)
'("EnableBlockRotation" -1)
'("EnableBlockScale" -1)
'("EnableDogleg" -1)
'("EnableFrameText" 0)
'("EnableLanding" -1)
'("FirstSegmentAngleConstraint" 0)
'("LandingGap" 0.2)
'("LeaderLineType"  1)
;;;	'("LeaderLineTypeId" "ByBlock") ;_ "Continuous"
'("LeaderLineTypeId" "Continuous") ;_ "ByBlock"
'("LeaderLineWeight" 30) ;;;Вес линий выноски
'("MaxLeaderSegmentsPoints" 2)
'("ScaleFactor" 1.0)
'("SecondSegmentAngleConstraint"  0)
'("TextAlignmentType" 0)
'("TextAngleType" 0)
'("TextHeight" 1.5) ;_Высота текста
'("TextLeftAttachmentType" 3)
'("TextRightAttachmentType" 3)
'("TextString"  "")
'("TextStyle" "STANDARD") ;;;Текстовый стиль Должен существовать
)
;;;(terpri)(princ item)
(vlax-put-property newldrstyle (car item)(cadr item))
  )
  newldrstyle
  )

Пояснения про DImblk
Еще один вариант mip-mleader-style-create

CAHTEXHuK · 18.02.2011, 11:49

может кто подсказать... такое дело... создаю достаточно простую мультивыноску с одной выноской по 2м точкам... она создается все вроде как хочу, только текст всегда оказывается слева от второй точки... а при минимальном движении акад уже меняет выноску с другой стороны... как должно быть... чета я не нашел метода, чтобы этот момент контролировать...

Код:

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

                    Set annotationObject = Nothing
                    insside = ThisDrawing.Utility.GetPoint(, vbCr & "Выберите точку вставки Выноски: ")
                    points(0) = Basepnt(0): points(1) = Basepnt(1):  points(2) = Basepnt(2)
                    points(3) = insside(0): points(4) = insside(1): points(5) = insside(2)
                    Set mlead = ThisDrawing.ModelSpace.AddMLeader(points, 1)
                    With mlead
                        .TextString = "текст"
                        .TextJustify = acAttachmentPointMiddleCenter
                    End With

Олег (jr.) · 18.02.2011, 13:25

Цитата:

Сообщение от CAHTEXHuK

может кто подсказать... такое дело... создаю достаточно простую мультивыноску с одной выноской по 2м точкам... она создается все вроде как хочу, только текст всегда оказывается слева от второй точки... а при минимальном движении акад уже меняет выноску с другой стороны... как должно быть... чета я не нашел метода, чтобы этот момент контролировать...

Код:

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

                    Set annotationObject = Nothing
                    insside = ThisDrawing.Utility.GetPoint(, vbCr & "Выберите точку вставки Выноски: ")
                    points(0) = Basepnt(0): points(1) = Basepnt(1):  points(2) = Basepnt(2)
                    points(3) = insside(0): points(4) = insside(1): points(5) = insside(2)
                    Set mlead = ThisDrawing.ModelSpace.AddMLeader(points, 1)
                    With mlead
                        .TextString = "текст"
                        .TextJustify = acAttachmentPointMiddleCenter
                    End With

Так будет работать:

Код:

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

Option Explicit
'' Set in  Tools--> Options--> General--> Break on Unhandled Errors
Sub test()
Dim p1, p2
Dim vec(2) As Double
Dim pts(5) As Double
Dim i As Long
Dim util As AcadUtility
Dim space As AcadModelSpace
Dim ml As AcadMLeader
With ThisDrawing
Dim tile As Integer
tile = .GetVariable("TILEMODE")
Set util = .Utility
Set space = IIf(tile = 1, .ModelSpace, .PaperSpace)
End With

Do While True

With util
On Error Resume Next
p1 = .GetPoint(, vbCrLf & "Pick starting point(or press Enter to Exit):")
 If Err Then
         If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then

             Err.Clear

Exit Sub
End If
End If


p2 = .GetPoint(p1, vbCrLf & "pick ending point:")
pts(0) = p1(0): pts(1) = p1(1): pts(2) = p1(2)
pts(3) = p2(0): pts(4) = p2(1): pts(5) = p2(2)

End With
Set ml = space.AddMLeader(pts, i) 'i=0
With ml
.ContentType = acMTextContent
If p2(0) > p1(0) Then
.TextJustify = acAttachmentPointMiddleLeft
vec(0) = 1: vec(1) = 0: vec(2) = 0
Else
vec(0) = -1: vec(1) = 0: vec(2) = 0
.TextJustify = acAttachmentPointMiddleRight
End If

.TextHeight = 4 '<-- text height
.ArrowheadSize = .TextHeight
.TextLineSpacingDistance = .TextHeight * 1.5
.DogLegged = True
.DoglegLength = .TextHeight
.SetDoglegDirection i, vec
.TextLeftAttachmentType = acAttachmentBottomOfTopLine
.TextRightAttachmentType = acAttachmentBottomOfTopLine
.TextString = "First Text Line\PSecond Text Line"

End With
Loop

End Sub

CAHTEXHuK · 18.02.2011, 14:38

Спасибо, несколько интересных моментов для себя отметил.

Олег (jr.) · 18.02.2011, 17:23

Цитата:

Сообщение от CAHTEXHuK

Спасибо, несколько интересных моментов для себя отметил.

замечательно

zvyagaaa · 12.08.2011, 10:56

добрый день. Решил не создавать новую тему, а поднять старую, т.к. по той же проблеме.
Делаю утилитку на дельфи, чтобы можно было создавать мультивыноски. Все вроде бы работает нормально, но есть один вопрос. Подскажите куда копать. В общем, когда я создаю выноску, она по умолчанию имеет линию выноски слева от текста, а иногда мне нужно справа от текста ее крепить? Какой параметр за это отвечает?

Код:

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

MLeader:=AcadDocument1.ModelSpace.AddMLeader(FirstPoint,i);
MLeader.TextString:=tempstr;
MLeader.ArrowheadType :=acArrowNone;

Вот так я делаею выноску. Простую, с одной линией без изломов.

Нефтепроводчик · 12.09.2011, 01:03

Посоветуйте, как на LISPe создать стиль мультивыноски с помощью entmake?
В посте VVA приведен объектный способ создания стиля мвыноски, но он, на мой взгляд, сложнее программного. Во-вторых, не задает ряд важных свойств стиля мультивыноски:
- нельзя отключить "Автоматически добавлять полку",
- указать для мтекста некоторые параметры, например, скрытие заднего фона текста.
С помощью entget можно извлечь DXF коды для мультивыносок, например программой из справки:

Код:

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

(defun C:PRINTDXF ( )
 (setq ent (entlast))     ; Set ent to last entity.
 (setq entl (entget ent)) ; Set entl to association list of 
 ; last entity.
 (setq ct 0)              ; Set ct (a counter) to 0.
 (textpage)               ; Switch to the text screen.
 (princ "\nentget of last entity:")
 (repeat (length entl)    ; Repeat for number of members in list:
 (print (nth ct entl))  ; Print a newline, then each list 
 ; member.
 (setq ct (1+ ct))      ; Increments the counter by one.
 )
 (princ)                  ; Exit quietly.
)

Как получить DXF коды именно для стилей мультивыносок?
В справке AutoCAD даны перечни кодов для стилей мультивыносок 4 типов (включая общий). Если мвыноска предусматривается с мтекстом, то нужно использовать MLeaderStyle Context Data Group Codes?
Настораживает, что некоторые номера кодов для разных стилей имеют разное назначение (например, 90 Property Override Flag для Common MLeaderStyle Group Codes и 90 Text Color для MLeaderStyle Context Data Group Codes).
Помогите разобраться.

Кулик Алексей aka kpblc · 12.09.2011, 02:02

Нефтепроводчик, стиль мультивыноски и объект мультивыноски - немного разные вещи. И, откровенно говоря, я бы не стал работать со стилями через DXF - объектная модель все же более удобна во многих случаях.

Oliver_88 · 12.09.2011, 09:23

Цитата:

Сообщение от Нефтепроводчик

как на LISPe создать стиль мультивыноски с помощью entmake?

Можно так.

Код:

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

 (setq style
       (entmakex '(
		   (0 . "MLEADERSTYLE")
		   (5 . "125")
		   (100 . "AcDbMLeaderStyle")
		   (179 . 2)
		   (170 . 2)
		   (171 . 1)
		   (172 . 0)
		   (90 . 2)
		   (40 . 0.0)
		   (41 . 0.0)
		   (173 . 1)
		   (91 . -1056964608)
		   (92 . -2)
		   (290 . 1)
		   (42 . 2.0)
		   (291 . 1)
		   (43 . 8.0)
		   (3 . "Standard")
		   (44 . 4.0)
		   (300 . "")
		   (174 . 1)
		   (178 . 1)
		   (175 . 1)
		   (176 . 0)
		   (93 . -1056964608)
		   (45 . 4.0)
		   (292 . 0)
		   (297 . 0)
		   (46 . 4.0)
		   (94 . -1056964608)
		   (47 . 1.0)
		   (49 . 1.0)
		   (140 . 1.0)
		   (293 . 1)
		   (141 . 0.0)
		   (294 . 1)
		   (177 . 0)
		   (142 . 1.0)
		   (295 . 0)
		   (296 . 0)
		   (143 . 3.75)
		   (271 . 0)
		   (272 . 9)
		   (273 . 9)
		   )
		 )
      )
(setq data_list
       (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE")
      )
(setq data_name (cdr(assoc -1 data_list)))
(dictadd data_name
	 "имя нового стиля"
	 style
	 )

Кулик Алексей aka kpblc · 12.09.2011, 09:25

Oliver_88, а теперь попробуй промоделировать следующую ситуацию: ты создал стиль, а пользователь взял да и поменял там пару-тройку настроек. Задача - вернуть все в нормальный вид.

VVA · 12.09.2011, 11:08

Цитата:

Сообщение от Нефтепроводчик

приведен объектный способ создания стиля мвыноски, но он, на мой взгляд, сложнее программного. Во-вторых, не задает ряд важных свойств стиля мультивыноски:

У меня изначально так же стиль создавался entmake'ом. Но в процессе работы столкнулся с тем, что при сохранении и открытии чертежа стали возникать ошибки в чертеже. После их исправления исчезал стиль мультивыноски. Я так и не разобрался, что нужно поправить в entmak'е. Вот код. Текстовый стиль МИП_ГОСТ должен существовать.

Код:

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

(VL-CATCH-ALL-APPLY '(lambda(  / tb tb-dic xr) 
;;Добавляем стиль мультивыноски 
(if (and (getvar "CMLEADERSTYLE") ;_Автокад поддерживает мультивыноски
         (setq tb-dic(DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE")) ;_Существует словарь мультивыносок
	 (not (member (cons 3 "MIP")(DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE")))); Отсутствует стиль мультивыноски MIP
  (progn
(if (not (tblobjname "block" "_None"))
       (progn
	 (setq tb (getvar "dimblk"))
	 (setvar "dimblk" "_None")
	 (setvar "dimblk" (if (= tb "") "." tb))
	 )
       )    
(setq tb (list
           '(0 . "MLEADERSTYLE")
            '(100 . "AcDbMLeaderStyle")
            '(170 . 2)
            '(171 . 1)
            '(172 . 0)
            '(90 . 2)
            '(40 . 0.0)
            '(41 . 0.0)
            '(173 . 1)
            '(91 . -1056964608)
            '(92 . -2)
            '(290 . 1)
            '(42 . 0.15)
            '(291 . 1)
            '(43 . 0.1)
            '(3 . "Mip-STYLE")
            '(44 . 0.5)
            '(300 . "")
            '(174 . 6)
            '(178 . 6)
            '(175 . 1)
            '(176 . 0)
            '(93 . -1056964608)
            '(45 . 1.5)
            '(292 . 0)
            '(297 . 0)
            '(46 . 4.0)
            '(94 . -1056964608)
            '(47 . 1.0)
            '(49 . 1.0)
            '(140 . 1.0)
            '(293 . 1)
            '(141 . 0.0)
            '(294 . 1)
            '(177 . 0)
            '(142 . 1.0)
            '(295 . 1)
            '(296 . 0)
            '(143 . 0.125)
           (cons 342 (tblobjname "style" "МИП_ГОСТ")) ;_Стиль
           
;;; Символ на конце
;;;    	    (cons 341 (cdr
;;;			(assoc 330
;;;			       (entget
;;;				 (tblobjname "block" "_None") ; _dot
;;;				 ) ;_ end of entget
;;;			       ) ;_ end of assoc
;;;			))
           )
       )
(if (setq xr (entmakex tb))
  (entmod (append tb-dic(list (cons 3 "MIP")(cons 350 xr))))
  )
))
(setq tb (cdr(assoc 350(member (cons 3 "MIP")(DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE")))))
(setq tb nil xr nil tb-dic nil )                       
))

Oliver_88 · 12.09.2011, 11:29

Кулик Алексей aka kpblc, с ходу не получается. Ковырятся надо.

Нефтепроводчик · 13.09.2011, 00:47

Спасибо, буду дальше разбираться.

Oliver_88 · 18.09.2011, 11:56

Цитата:

Сообщение от Кулик Алексей aka kpblc

Oliver_88, а теперь попробуй промоделировать следующую ситуацию: ты создал стиль, а пользователь взял да и поменял там пару-тройку настроек. Задача - вернуть все в нормальный вид.

Вроде бы вернул.

Код:

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

 ;(test1 "имя нового стиля")
(defun test1 (st_name /)
  (setq	lst1
	 '(
	   (0 . "MLEADERSTYLE")
	   (100 . "AcDbMLeaderStyle")
	   (179 . 2)
	   (170 . 2)
	   (171 . 1)
	   (172 . 0)
	   (90 . 2)
	   (40 . 0.0)
	   (41 . 0.0)
	   (173 . 1)
	   (91 . -1056964608)
	   (92 . -2)
	   (290 . 1)
	   (42 . 2.0)
	   (291 . 1)
	   (43 . 8.0)
	   (3 . "Standard")
	   (44 . 4.0)
	   (300 . "")
	   (174 . 1)
	   (178 . 1)
	   (175 . 1)
	   (176 . 0)
	   (93 . -1056964608)
	   (45 . 4.0)
	   (292 . 0)
	   (297 . 0)
	   (46 . 4.0)
	   (94 . -1056964608)
	   (47 . 1.0)
	   (49 . 1.0)
	   (140 . 1.0)
	   (293 . 1)
	   (141 . 0.0)
	   (294 . 1)
	   (177 . 0)	
	   (142 . 1.0)
	   (295 . 0)
	   (296 . 0)
	   (143 . 3.75)
	   (271 . 0)
	   (272 . 9)
	   (273 . 9)
	  )
  )
  (setq	null_name
	 (cdr
	   (assoc 330
		  (entget
		    (cdr
		      (assoc 330
			     (entget
			       (cdr
				 (assoc	330
					(entget
					  (tblobjname "BLOCK" "*Model_Space")
					)
				 )
			       )
			     )
		      )
		    )
		  )
	   )
	 )
  )
  (entmod
    (test
      (dictsearch
	(cdr
	  (assoc -1
		 (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE")
		 )
	  )
	st_name
	)
      lst1
      null_name
      )
    )
  (princ)
)
(defun test (lst lst1 null_name / el)
  (cond
    (
     (member (caar lst) (list -1 0 5 102 330))
     (cons (car lst) (test (cdr lst) lst1 null_name))
     )
    (
     (setq el (assoc (caar lst) lst1))
     (cons el (test (cdr lst) (cdr lst1) null_name))
     )
    (
     lst
     (cons
       (cons
	 (caar lst)
	 null_name
	 )
       (test (cdr lst) lst1 null_name)
       )
     )
    )
  )

Apelsinov · 30.11.2011, 17:51

у меня вопрос, похожий на тот что в #23
модифицирую выноску

Код:

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

 (vlax-invoke ml_obj 'SetLeaderLineVertices 0 list_2points)
; где ml_obj - объект мультивыноски
; list_2points - список координат двух точек этой выноски, типа (list 0.0 0.0 0.0 -1.0 1.0 0.0)

так вот, при любых координатах в list_2points линия выноски оказывается слева от текста. Как это регулировать можно?

Олег (jr.) · 30.11.2011, 19:18

Выдерни нужное из этого кода
см. SetdoglegDirection

Код:

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

 (defun C:MLF (/ acsp adoc col dht ent mlead p1 p2 pline pt1 pt2 ptarr txt)
  (vl-load-com)
  (or adoc
      (setq adoc
	     (vla-get-activedocument
	       (vlax-get-acad-object)
	       )
	    )
      )
  (if (and
	(= (getvar "tilemode") 0)
	(= (getvar "cvport") 1)
	)
    (setq acsp (vla-get-paperspace adoc))
    (setq acsp (vla-get-modelspace adoc))
    )

  (setq	col (vla-getinterfaceobject
	      (vlax-get-acad-object)
	      (strcat "autocad.accmcolor."
		      (vl-princ-to-string (atoi (getvar "acadver")))))
	)
  (while (setq ent (entsel "\n >> Выбрать полилинию >> \n"))
    (progn
      (setq pline (vlax-ename->vla-object (car ent))
	    )
      (setq txt
		(strcat
		  "%<\\AcObjProp Object(%<\\_ObjId "
		  (itoa (vla-get-objectid pline))
		  ">%).Layer \\f \"%tc4\">%"
		  )

	    txt	(strcat	txt
			"\\P"
			"%<\\AcObjProp Object(%<\\_ObjId "
			(itoa (vla-get-objectid pline))
			">%).Length \\f \"%lu2%ps[L=,м]%zs8\">%"))

      (setq p1 (vlax-curve-getclosestpointto pline (cadr ent))
	    p2 (getpoint p1 "\nТочка полочки выноски >> \n")
	    )
      (setq ptarr (vlax-make-variant
		    (vlax-safearray-fill
		      (safearray vlax-vbdouble '(0 . 5))
		      (apply 'append (list p1 p2))))
	    )

      (setq mlead (vla-addmleader acsp ptarr 0))
      (vla-put-contenttype mlead acMTextContent)
      (vla-put-textheight mlead(getvar "dimtxt"))
      (vla-put-landinggap mlead 0.09)
      (vla-put-textstring mlead txt)
;;;(vla-put-layer mlead (vla-get-layer pline));; <-- не работает потому что в имени слоя некорректный символ (диаметр)
     (vla-put-doglegged mlead :vlax-true)
      (vla-put-dogleglength mlead 0.05)
      ;;borrowed from LeeMac:
      (vla-setdoglegdirection
	mlead
	0
	(vlax-3D-point
	  (list
	    (if	(<= (car p1) (car p2))
	      1
	      -1)
	    0
	    0
	    )
	  )
	)
      (if (>= (car p2) (car p1))
      (vla-put-TextJustify mlead acAttachmentPointMiddleLeft)
      (vla-put-TextJustify mlead acAttachmentPointMiddleRight)
	)
      (vla-put-TextLeftAttachmentType mlead acAttachmentBottomOfTopLine)
      (vla-put-TextRightAttachmentType mlead acAttachmentBottomOfTopLine)
      (vla-put-leaderlineweight mlead acLnWt025)
      (vla-put-leadertype mlead 1)
      (vla-put-colorindex col 256)
      (vla-put-truecolor mlead col)
      (vla-put-leaderlinecolor mlead col)

      )
    )
  (vl-catch-all-apply
    (function (lambda ()
		(vlax-release-object col)
		)
	      )
    )
  (vla-regen adoc acactiveviewport)
  (princ)
)
(prompt "\n")
(prompt "\t\t<<< Ввести MLF для старта программы\t>>> ")
(princ)

Apelsinov · 01.12.2011, 11:39

Цитата:

Сообщение от Олег (jr.)

Выдерни нужное из этого кода
см. SetdoglegDirection

у меня получается частично решить проблему с помощью

Код:

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

 (vla-put-TextAttachmentDirection ml_obj 0)
; где ml_obj - объект мультивыноски

В этом случае акад сам выбирает положение выносной линии относительно полки выноски.
Но как и в случае с SetdoglegDirection, это немного не то. Интересует изменение положения полки выноски, относительно выносной линии. То есть если мы задаем точки p1 и p2, то нужно чтобы выносная линия была отрисована как p1-p2, а полка выноски отображалась справа или слева, в зависимости от угла наклона линии выноски.

Offtop: Я извиняюсь за, возможно, глупые вопросы по поводу свойств объектов, но у меня не работает нормально справка по объектной модели.

Олег (jr.) · 01.12.2011, 23:07

Попробуй так, только рнемного с геометрией надо повозиться,
чтобы точно пересчитывать точки всех линий мультилидера

Код:

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

 (vl-load-com)
(defun C:Demo (/ acsp adoc axss  mlead p1 p2 p3  ptarr ss str_text)
  
  (or adoc
      (setq adoc
	     (vla-get-activedocument
	       (vlax-get-acad-object)
	       )
	    )
      )
  (if (and
	(= (getvar "tilemode") 0)
	(= (getvar "cvport") 1)
	)
    (setq acsp (vla-get-paperspace adoc))
    (setq acsp (vla-get-modelspace adoc))
    )
(setvar 'qtextmode 0)
(setvar 'orthomode 0)
        (setq p1 (getpoint  "\nPick arrow point >> \n")
	    p2 (getpoint p1 "\nPick start of text line >> \n")
	    )
  (setvar 'orthomode 1)
   (setq   p3 (getpoint p2 "\nPick end of text line >> \n"))
          (setvar 'orthomode 0)
            (setq str_text "Blah\nBlah\nBlah")
      (setq ptarr (vlax-make-variant
		    (vlax-safearray-fill
		      (safearray vlax-vbdouble '(0 . 5))
		      (apply 'append (list p1 p2 ))))
	    )

      (setq mlead (vla-addmleader acsp ptarr 0))
      (vla-put-leadertype mlead 1)
      (vla-put-contenttype mlead acMTextContent)
      (vla-put-textheight mlead 0.28);<--change  text height here
      (vla-put-landinggap mlead 0.07)
      (vla-put-textstring mlead str_text)

     (vla-put-doglegged mlead :vlax-true)
     (vla-put-dogleglength mlead 0.01)
      ;;borrowed from Lee Mac:
      (vla-setdoglegdirection
	mlead
	0
	(vlax-3D-point
	  (list
	    (if	(<= (car p2) (car p3))
	      1
	      -1)
	    0
	    0
	    )
	  )
	)
      (if (>= (car p3) (car p2))
      (vla-put-TextJustify mlead acAttachmentPointMiddleLeft)
      (vla-put-TextJustify mlead acAttachmentPointMiddleRight)
	)
      
      (vla-put-TextLeftAttachmentType mlead 7);acAttachmentBottomLine- 7

      (vla-put-TextRightAttachmentType mlead 7);acAttachmentMiddleOfTop - 1;;acAttachmentMiddleOfBottom - 5

     (vla-put-TextFrameDisplay mlead :vlax-false) ;<-- to display text frame :vlax-true
  
      (vla-put-leaderlineweight mlead -3)

  (princ)
)

VVA · 21.02.2012, 18:18

Из тем How to set new MLeaderStyle properties и Modify a MultiLeader text style, leader style

Код:

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

;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
;;; Xander http://www.theswamp.org/index.php?topic=40944.0
;;;	<function>cadcoder:createmultileaderstyle</function>
;;;	<summary>Creates a MultiLeader style in accordance with GT standards</summary>
;;;	<param name="$stylename">Multileader Style name</param>
;;;	<param name="$fontname">Textstyle name to use</param>
;;;	 
;;;	<returns>Nothing</returns>

;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
(DEFUN cadcoder:createmultileaderstyle ($stylename $fontstyle / $styleentity lst)
    (DEFUN createmultileader (data / dic obj)
        ;;If we can reference the Mleaderstyle dictionary object
        ;;and the proposed style name doesn't exist
        ;;and the entmake was successful
        (IF (AND (SETQ dic (DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE"))
                 (NOT (DICTSEARCH (SETQ dic (CDR (ASSOC -1 dic))) "GTSTD"))
                 (SETQ obj (ENTMAKEX data))
            )
            ;;Add the style to the dictionary
            (DICTADD dic (CDR (ASSOC 3 data)) obj)
        )
    )
    ;;If the text style doesn't exist, exit
    (IF (= nil (TBLSEARCH "STYLE" $fontstyle))
        (EXIT)
    )
    ;;Create the Mleader DXF style list
    (SETQ lst
             (LIST
                 (CONS 0 "MLEADERSTYLE")
                 (CONS 100 "AcDbMLeaderStyle")
                 (CONS 179 2) ;Text Attachment Point
                 (CONS 170 2) ;Content Type
                 (CONS 171 1) ;Draw MLeaderOrder Type
                 (CONS 172 0) ;DrawLeaderOrderType
                 (CONS 90 0) ;MaxLeader Segments
                 (CONS 40 0.0) ;First Segment Angle Constraint
                 (CONS 41 0.0) ;Second Segment Angle Constraint
                 (CONS 173 1) ;Leader Line Type
                 (CONS 91 (colour->mleaderstylecolour 1)) ;Leader Line Color (Red)
                 (CONS 340 (TBLOBJNAME "LTYPE" "ByLayer")) ;Leader Line Type
                 (CONS 92 -1) ;Leader Line weight
                 (CONS 290 1) ;Enable Landing
                 (CONS 42 1.5) ;Landing Gap
                 (CONS 291 1) ;Enable Dog Leg
                 (CONS 43 3) ;Dog Leg Length
                 (CONS 3 $stylename) ;MLeaderDescription
                 (CONS 341 (CDR (ASSOC 330 (ENTGET (TBLOBJNAME "BLOCK" "GT-ARR7"))))) ;Leader ArrowID
                 (CONS 44 1) ;Arrow Head Size
                 (CONS 300 "") ;Default Text contents
                 (CONS 342 (TBLOBJNAME "STYLE" $fontstyle)) ;MTextStyleID
                 (CONS 174 1) ;Text Left Attachment Type
                 (CONS 178 1) ;Text Right Attachment Type
                 (CONS 175 1) ;Text Angle Type
                 (CONS 176 0) ;Text Alignment Type
                 (CONS 93 (colour->mleaderstylecolour 3)) ;Text Color
                 (CONS 45 0) ;Text Height
                 (CONS 292 0) ;Enable Frame Text
                 (CONS 297 1) ;Text Always Left Justify
                 (CONS 46 0.18) ;Align Space
                 (CONS 142 1.0) ;Scale
                 (CONS 295 1) ;Overright Property Value
                 (CONS 296 0) ;Is Annotative
                 (CONS 143 0.0) ;Break Gap Size
                 (CONS 271 0) ;Text Attachment Direction (0 = Horizontal, 1 = Vertical)
                 (CONS 272 9) ;Bottom Text Attachment Direction (9 = Center, 10 = Underline & Center)
                 (CONS 273 9) ;Top Text Attachment Direction (9 = Center, 10 = Underline & Center)
             )
    )
    ;;Create the MLeader Style dictionary
    (createmultileader lst)
    ;;Set the new style as current
    (SETVAR "CMLEADERSTYLE" $stylename)
    (PRINC)
)
 
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
;|
<function>color->mleaderstylecolor</function>
<summary>Converts an ACI color to an mleader color.</sumary>
<param name="c">ACI color</param>
 
<returns>Mleader color expressed as a 24bit value.</returns>
|;
 ;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
(DEFUN colour->mleaderstylecolour (c)
    ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
    ;|
    <function>color:rgb->true</function>
    <summary>Converts an RGB color to a true color</sumary>
    <param name="r">Red color value</param>
    <param name="g">Green color value</param>
    <param name="b">Blue color value</param>
    <returns>Color value</returns>
    |;
    ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
 
    (DEFUN color:rgb->true (r g b)
        (+
            (LSH (FIX r) 16)
            (LSH (FIX g) 8)
            (FIX b)
        )
    )
    (COND
        ((LISTP c)
         (+ -1040187392 (APPLY 'color:rgb->true c))
        )
        ((= 0 c)
         -1056964608
        )
        ((= 256 c)
         -1073741824
        )
        ((< 0 c 256)
         (+ -1023410176 (color:rgb->true 0 0 c))
        )
    )
)
 
 
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
;|
<function>mleaderstylecolor->color</function>
<summary>Converts an MLeader color to the True or ACI color.</sumary>
<param name="c">Mleader color</param>
 
<returns>True or ACI color.</returns>
|;
 ;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
(DEFUN mleaderstylecolour->colour (c)
 
    ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
    ;|
    <function>color:true->rgb</function>
    <summary>Converts an True color to a RGB color</sumary>
    <param name="c">True color to convert</param>
    <returns>Color value</returns>
    |;
    ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
    (DEFUN color:true->rgb (c)
        (LIST
            (LSH (LSH (FIX c) 8) -24)
            (LSH (LSH (FIX c) 16) -24)
            (LSH (LSH (FIX c) 24) -24)
        )
    )
    (IF (< 0 (LOGAND 16777216 c))
        (LAST (color:true->rgb c))
        (IF (EQUAL '(0 0 0) (SETQ c (color:true->rgb c)))
            256
            c
        )
    )
)

Profan · 23.10.2012, 20:48

Для VVA.
Как с помощью кода, описанного в сообщении #18, создать стиль мультивыноски с символом стрелки "Закрашенная замкнутая" ("Closed filled")?
Выражения
(mip-mleader-style-create "СТРОЙЗАДАНИЕ" ".")
(setvar "CMLEADERSTYLE" (vla-get-name (mip-mleader-style-create "СТРОЙЗАДАНИЕ" ".")))
выдают ошибку:
Команда: ; ошибка: Ошибка Automation. Ключ не найден

VVA · 19.12.2012, 10:46

Profan, Извини, как-то пропустил твой вопрос
Значение dimblk - одно из возможных значений переменной _DIMBLK
В твоем случае

Код:

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

(mip-mleader-style-create "СТРОЙЗАДАНИЕ" "_Dot")

Profan · 19.12.2012, 12:06

VVA, спасибо, но я разобрался еще в октябре.

Alikme · 17.06.2015, 08:03

Код VVA выдает такую ошибку: "; ошибка: Ошибка Automation. Проблемы при загрузке приложения", причем на домашнем компьютере с автокадом 2014 - всё работает... При этом стиль успевает создать, а настройки стиля - нет. С чем может быть такое связано?

100k · 17.06.2015, 08:59

так в Tekla есть мультивыноска

VVA · 17.06.2015, 09:19

Alikme, А на какой версии Автокада выдает ошибку?

Alikme · 17.06.2015, 10:26

Так же в 2014-ом!
Я подозреваю вот это место, но не могу понять что не так...

Код:

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

 (setq objcolor (vla-getinterfaceobject
(vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar "acadver") 1 2))
) ;_vla-getinterfaceobject

VVA · 17.06.2015, 14:13

Проверь этим вариантом.

Код:

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

 
(defun mip-mleader-style-create (mleaderstylename
                                 dimblk         /
                                 mldrdict       newldrstyle
                                 textcolor      leadercolor
                                 objcolor
                                )
;;; Программное создание мультивыноски   http://forum.dwg.ru/showthread.php?t=27965&page=3
;;;   mleaderstylename - имя стиля
;;;   dimblk - имя блока на конце (см переменную DIMBLK ниже, например _Dot) или nil - нет
;;; Для стиля берется текущий текстовый стиль из переменной "TEXTSTYLE"
;;; Для задания своего стиля заменить (getvar "TEXTSTYLE") на имя своего стиля. Текстовый стиль должен существовать!!!!
;;; Возвращает указатель на объект созданного стиля
;;; Пример:
;;;  (mip-mleader-style-create "Test-O90" "_OPEN90")
;;;  (mip-mleader-style-create "Test-O91" "_Dot")
;;;  (mip-mleader-style-create "Test-O92" nil)  
;;; Установить стиль текущим
;;; (setvar "CMLEADERSTYLE" (vla-get-name (mip-mleader-style-create "Skkk" nil)))  
  
;;; Возможные варианты значений Dimblk
;;;;         "_ARCHTICK" 	= Architectural tick
;;;;         "_BOXBLANK" 	= Box
;;;;         "_BOXFILLED" 	= Box filled
;;;;         "_CLOSED" 	= Closed
;;;;         "_CLOSEDBLANK"= Closed blank
;;;;         "." 		= none
;;;;         "_DATUMBLANK" = Datum triangle
;;;;         "_DATUMFILLED"= Datum triangle filled
;;;;         "_DOT"	 = Dot
;;;;         "_DOTBLANK" 	= Dot blank
;;;;         "_DOTSMALL" 	= Dot small
;;;;         "_SMALL" 	= Dot small blank
;;;;         "_INTEGRAL" 	= Integral
;;;;         "_NONE" 	= None
;;;;         "_OBLIQUE" 	= Oblique
;;;;         "_OPEN" 	= Open
;;;;         "_OPEN30" 	= Open 30
;;;;         "_ORIGIN" 	= Origin indicator
;;;;         "_ORIGIN2" 	= Origin indicator 2
;;;;         "_OPEN90" 	= Right angle

;;; Проверка наличия стиля
;;;(setq mleaderstylename "MIP")
;;;  (if (and (getvar "CMLEADERSTYLE") ;;;Автокад поддерживает мультивыноски
;;;         (setq tb-dic(DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE"))
;;;	 (not (member (cons 3 (strcase mleaderstylename))(DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE"))))
;;;    (progn )
;;;    )

;;; http://www.theswamp.org/index.php?topic=40944.0
  ;|
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
;;; Xander http://www.theswamp.org/index.php?topic=40944.0
;;;	<function>cadcoder:createmultileaderstyle</function>
;;;	<summary>Creates a MultiLeader style in accordance with GT standards</summary>
;;;	<param name="$stylename">Multileader Style name</param>
;;;	<param name="$fontname">Textstyle name to use</param>
;;;	 
;;;	<returns>Nothing</returns>

;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
(DEFUN cadcoder:createmultileaderstyle ($stylename $fontstyle / $styleentity lst)
    (DEFUN createmultileader (data / dic obj)
        ;;If we can reference the Mleaderstyle dictionary object
        ;;and the proposed style name doesn't exist
        ;;and the entmake was successful
        (IF (AND (SETQ dic (DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE"))
                 (NOT (DICTSEARCH (SETQ dic (CDR (ASSOC -1 dic))) "GTSTD"))
                 (SETQ obj (ENTMAKEX data))
            )
            ;;Add the style to the dictionary
            (DICTADD dic (CDR (ASSOC 3 data)) obj)
        )
    )
    ;;If the text style doesn't exist, exit
    (IF (= nil (TBLSEARCH "STYLE" $fontstyle))
        (EXIT)
    )
    ;;Create the Mleader DXF style list
    (SETQ lst
             (LIST
                 (CONS 0 "MLEADERSTYLE")
                 (CONS 100 "AcDbMLeaderStyle")
                 (CONS 179 2) ;Text Attachment Point
                 (CONS 170 2) ;Content Type
                 (CONS 171 1) ;Draw MLeaderOrder Type
                 (CONS 172 0) ;DrawLeaderOrderType
                 (CONS 90 0) ;MaxLeader Segments
                 (CONS 40 0.0) ;First Segment Angle Constraint
                 (CONS 41 0.0) ;Second Segment Angle Constraint
                 (CONS 173 1) ;Leader Line Type
                 (CONS 91 (colour->mleaderstylecolour 1)) ;Leader Line Color (Red)
                 (CONS 340 (TBLOBJNAME "LTYPE" "ByLayer")) ;Leader Line Type
                 (CONS 92 -1) ;Leader Line weight
                 (CONS 290 1) ;Enable Landing
                 (CONS 42 1.5) ;Landing Gap
                 (CONS 291 1) ;Enable Dog Leg
                 (CONS 43 3) ;Dog Leg Length
                 (CONS 3 $stylename) ;MLeaderDescription
                 (CONS 341 (CDR (ASSOC 330 (ENTGET (TBLOBJNAME "BLOCK" "GT-ARR7"))))) ;Leader ArrowID
                 (CONS 44 1) ;Arrow Head Size
                 (CONS 300 "") ;Default Text contents
                 (CONS 342 (TBLOBJNAME "STYLE" $fontstyle)) ;MTextStyleID
                 (CONS 174 1) ;Text Left Attachment Type
                 (CONS 178 1) ;Text Right Attachment Type
                 (CONS 175 1) ;Text Angle Type
                 (CONS 176 0) ;Text Alignment Type
                 (CONS 93 (colour->mleaderstylecolour 3)) ;Text Color
                 (CONS 45 0) ;Text Height
                 (CONS 292 0) ;Enable Frame Text
                 (CONS 297 1) ;Text Always Left Justify
                 (CONS 46 0.18) ;Align Space
                 (CONS 142 1.0) ;Scale
                 (CONS 295 1) ;Overright Property Value
                 (CONS 296 0) ;Is Annotative
                 (CONS 143 0.0) ;Break Gap Size
                 (CONS 271 0) ;Text Attachment Direction (0 = Horizontal, 1 = Vertical)
                 (CONS 272 9) ;Bottom Text Attachment Direction (9 = Center, 10 = Underline & Center)
                 (CONS 273 9) ;Top Text Attachment Direction (9 = Center, 10 = Underline & Center)
             )
    )
    ;;Create the MLeader Style dictionary
    (createmultileader lst)
    ;;Set the new style as current
    (SETVAR "CMLEADERSTYLE" $stylename)
    (PRINC)
)
 
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;

;;;<function>color->mleaderstylecolor</function>
;;;<summary>Converts an ACI color to an mleader color.</sumary>
;;;<param name="c">ACI color</param>
;;; 
;;;<returns>Mleader color expressed as a 24bit value.</returns>

 ;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
(DEFUN colour->mleaderstylecolour (c)
    ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
    
;;;    <function>color:rgb->true</function>
;;;    <summary>Converts an RGB color to a true color</sumary>
;;;    <param name="r">Red color value</param>
;;;    <param name="g">Green color value</param>
;;;    <param name="b">Blue color value</param>
;;;    <returns>Color value</returns>
;;;    
    ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
 
    (DEFUN color:rgb->true (r g b)
        (+
            (LSH (FIX r) 16)
            (LSH (FIX g) 8)
            (FIX b)
        )
    )
    (COND
        ((LISTP c)
         (+ -1040187392 (APPLY 'color:rgb->true c))
        )
        ((= 0 c)
         -1056964608
        )
        ((= 256 c)
         -1073741824
        )
        ((< 0 c 256)
         (+ -1023410176 (color:rgb->true 0 0 c))
        )
    )
)
 
 
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;

;;;<function>mleaderstylecolor->color</function>
;;;<summary>Converts an MLeader color to the True or ACI color.</sumary>
;;;<param name="c">Mleader color</param>
;;; 
;;;<returns>True or ACI color.</returns>

 ;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
(DEFUN mleaderstylecolour->colour (c)
 
    ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
    
;;;    <function>color:true->rgb</function>
;;;    <summary>Converts an True color to a RGB color</sumary>
;;;    <param name="c">True color to convert</param>
;;;    <returns>Color value</returns>
    
    ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-;;
    (DEFUN color:true->rgb (c)
        (LIST
            (LSH (LSH (FIX c) 8) -24)
            (LSH (LSH (FIX c) 16) -24)
            (LSH (LSH (FIX c) 24) -24)
        )
    )
    (IF (< 0 (LOGAND 16777216 c))
        (LAST (color:true->rgb c))
        (IF (EQUAL '(0 0 0) (SETQ c (color:true->rgb c)))
            256
            c
        )
    )
)
|;
  ;|
(setq result "NO")
(if (setq dict (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE"))
(foreach x dict 
(if (and (= (car x) 3) (eq (strcase (cdr x)) (strcase "Normal")))
(setq result "YES")
)
)
)
(if (= result "NO")(progn
(setq *doc* (vla-get-activedocument (vlax-get-acad-object)))
(setq mldrdict (vla-item (vla-get-dictionaries *doc*) "ACAD_MLEADERSTYLE"))
(setq newldrstyle (vlax-invoke mldrdict 'addobject "Normal" "AcDbMLeaderStyle"))
(setq txtcol 7 ldrcol 8)
(setq colorObj (vla-getinterfaceobject (vlax-get-acad-object) "AutoCAD.AcCmColor.17"))
(vla-put-ColorIndex colorObj txtcol)
(vla-put-TextColor newldrstyle colorObj)
(vla-put-ColorIndex colorObj ldrcol)
(vla-put-LeaderLineColor newldrstyle colorObj)
(vlax-put-property newldrstyle 'AlignSpace 0.18)
(vlax-put-property newldrstyle 'Annotative 0)
(vlax-put-property newldrstyle 'ArrowSize 10.0)
(vlax-put-property newldrstyle 'BlockConnectionType 0)
(vlax-put-property newldrstyle 'BlockRotation 0.0)
(vlax-put-property newldrstyle 'BlockScale 10.0)
(vlax-put-property newldrstyle 'BreakSize 6.0)
(vlax-put-property newldrstyle 'ContentType 2)
(vlax-put-property newldrstyle 'Description "Normal")
(vlax-put-property newldrstyle 'DoglegLength 6.0)
(vlax-put-property newldrstyle 'DrawLeaderOrderType 0)
(vlax-put-property newldrstyle 'DrawMLeaderOrderType 1)
(vlax-put-property newldrstyle 'EnableBlockRotation -1)
(vlax-put-property newldrstyle 'EnableBlockScale -1)
(vlax-put-property newldrstyle 'EnableDogleg -1)
(vlax-put-property newldrstyle 'EnableFrameText 0)
(vlax-put-property newldrstyle 'EnableLanding -1)
(vlax-put-property newldrstyle 'FirstSegmentAngleConstraint 0)
(vlax-put-property newldrstyle 'LandingGap 4.0)
(vlax-put-property newldrstyle 'LeaderLineType 1)
(vlax-put-property newldrstyle 'LeaderLineTypeId "Continuous")
(vlax-put-property newldrstyle 'LeaderLineWeight -1)
(vlax-put-property newldrstyle 'MaxLeaderSegmentsPoints 9)
(vlax-put-property newldrstyle 'name "Normal")
(vlax-put-property newldrstyle 'ScaleFactor 1.0)
(vlax-put-property newldrstyle 'SecondSegmentAngleConstraint 0)
(vlax-put-property newldrstyle 'TextAlignmentType 1)
(vlax-put-property newldrstyle 'TextAngleType 1)
(vlax-put-property newldrstyle 'TextHeight 6.0)
(vlax-put-property newldrstyle 'TextLeftAttachmentType 1)
(vlax-put-property newldrstyle 'TextRightAttachmentType 1)
(vlax-put-property newldrstyle 'TextString "")
(vlax-put-property newldrstyle 'TextStyle "SSE")
))
(command "._cmleaderstyle" "Normal")

|;

  ;|
(vl-load-com)
(defun mleadercreate (/ *doc* mldrdict newldrstyle) 
    (setq *doc* (vla-get-activedocument (vlax-get-acad-object))) 
    (setq mldrdict (vla-item (vla-get-dictionaries *doc*) "ACAD_MLEADERSTYLE")) 
    (setq newldrstyle (vlax-invoke mldrdict 'addobject "CM_Mleader" "AcDbMLeaderStyle")) 
    (setq txtcol 0 ldrcol 0) 
    (setq colorObj (vla-getinterfaceobject (vlax-get-acad-object) "AutoCAD.AcCmColor.17")) 
    (vla-put-ColorIndex colorObj txtcol) 
    (vla-put-ColorIndex colorObj ldrcol) 
    (vlax-put-property newldrstyle 'AlignSpace 5.0) 
;; Leader format
    (vlax-put-property newldrstyle 'LeaderLineType 1) 
    (vla-put-LeaderLineColor newldrstyle colorObj) 
;    (vlax-put-property newldrstyle 'LeaderLineTypeId "Bylayer" )
    (vlax-put-property newldrstyle 'LeaderLineWeight -2)
    (vlax-put-property newldrstyle 'ArrowSymbol "_dot") 
    (vlax-put-property newldrstyle 'ArrowSize 0.125)
    (vlax-put-property newldrstyle 'BreakSize 0.099609375) 
;; Leader Structure
    (vlax-put-property newldrstyle 'MaxLeaderSegmentsPoints 0)
    (vlax-put-property newldrstyle 'FirstSegmentAngleConstraint 0) 
    (vlax-put-property newldrstyle 'SecondSegmentAngleConstraint 0) 
    (vlax-put-property newldrstyle 'EnableLanding -1)
    (vlax-put-property newldrstyle 'EnableDogleg -1) 
    (vlax-put-property newldrstyle 'DoglegLength -2.0) 
    (vlax-put-property newldrstyle 'Annotative 0)
    (vlax-put-property newldrstyle 'ScaleFactor 1.0) 
;; Content
    (vlax-put-property newldrstyle 'ContentType 0) 
    (vlax-put-property newldrstyle 'TextString "") 
    (vlax-put-property newldrstyle 'TextStyle (getvar "textstyle")) 
    (vlax-put-property newldrstyle 'TextAngleType 0) 
    (vla-put-TextColor newldrstyle colorObj)
    (vlax-put-property newldrstyle 'TextHeight 0.2)  
    (vlax-put-property newldrstyle 'TextAlignmentType 0) 
    (vlax-put-property newldrstyle 'EnableFrameText 0) 
    (vlax-put-property newldrstyle 'TextAttachmentDirection 0)
    (vlax-put-property newldrstyle 'TextBottomAttachmentType 0)  
    (vlax-put-property newldrstyle 'TextLeftAttachmentType 2) 
    (vlax-put-property newldrstyle 'TextRightAttachmentType 3) 
    (vlax-put-property newldrstyle 'TextTopAttachmentType 0) 
    (vlax-put-property newldrstyle 'LandingGap 0.029296875) 
    (vlax-put-property newldrstyle 'BlockConnectionType 0) 
    (vlax-put-property newldrstyle 'BlockRotation 0.0) 
    (vlax-put-property newldrstyle 'BlockScale 1.0) 
    (vlax-put-property newldrstyle 'DrawLeaderOrderType 0) 
    (vlax-put-property newldrstyle 'DrawMLeaderOrderType 1) 
    (vlax-put-property newldrstyle 'EnableBlockRotation -1) 
    (vlax-put-property newldrstyle 'EnableBlockScale -1) 
    (vlax-put-property newldrstyle 'Description "CM_Mleader") 
    (vlax-put-property newldrstyle 'name "CM_Mleader") 
)
|;
  (or dimblk (setq dimblk "_None"))
  (setq mldrdict
         (vla-item (vla-get-dictionaries
                     (vla-get-activedocument (vlax-get-acad-object))
                   ) ;_ end of vla-get-dictionaries
                   "ACAD_MLEADERSTYLE"
         ) ;_ end of vla-item
  ) ;_ end of setq
  (if (vl-catch-all-error-p
        (vl-catch-all-apply
          '(lambda ()
             (setq newldrstyle
                    (vlax-invoke
                      mldrdict
                      'addobject
                      mleaderstylename
                      "AcDbMLeaderStyle"
                    ) ;_ end of vlax-invoke
             ) ;_ end of setq
           ) ;_ end of lambda
        ) ;_ end of VL-CATCH-ALL-APPLY
      ) ;_ end of VL-CATCH-ALL-ERROR-P
    (vlax-ename->vla-object
      (cdr
        (assoc
          350
          (member
            (cons 3
                  (MIP-MLEADER-STYLE-CREATE-DXF mleaderstylename dimblk)
            ) ;_ end of cons
            (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE")
          ) ;_ end of member
        ) ;_ end of assoc
      ) ;_ end of cdr
    ) ;_ end of vlax-ename->vla-object
    (progn
      (setq textcolor acbyblock)
;;;Цвет текста
      (setq leadercolor acbyblock)
;;;Цвет выноски
      (setq objcolor (vla-getinterfaceobject
                       (vlax-get-acad-object)
                       (strcat "AutoCAD.AcCmColor."
                               (substr (getvar "acadver") 1 2)
                       ) ;_ end of strcat
                     ) ;_vla-getinterfaceobject
      ) ;_setq
      (vla-put-colorindex objcolor textcolor)
      (vla-put-textcolor newldrstyle objcolor)
      (vla-put-colorindex objcolor leadercolor)
      (vla-put-leaderlinecolor newldrstyle objcolor)
      (if (not (tblobjname "block" dimblk))
        (progn
          (setq textcolor (getvar "dimblk"))
          (if (vl-catch-all-error-p
                (vl-catch-all-apply 'setvar (list "dimblk" dimblk))
              ) ;_ end of VL-CATCH-ALL-ERROR-P
            (setvar "dimblk" (setq dimblk "_None"))
          ) ;_ end of if
          (setvar "dimblk"
                  (if (= textcolor "")
                    "."
                    textcolor
                  ) ;_ end of if
          ) ;_ end of setvar
        ) ;_ end of progn
      ) ;_ end of if
      (foreach item
                    (list
                      '("AlignSpace" 5.0)
                      '("Annotative" 0)
                      '("ArrowSize" 0.30) ;_Размер стрелки
                      (list "ArrowSymbol" dimblk)
                      '("BitFlags" 0)
                      
;;;("Block"  "")
                      '
                       ("BlockConnectionType" 0)
                      '("BlockRotation" 0.0)
                      '("BlockScale" 1.0)
                      '("BreakSize" 0.125)
                      '("ContentType" 2)
                      '("Description" "Стиль УП Минскинжпроект")
                      '("DoglegLength" 0.3)
                      '("DrawLeaderOrderType" 0)
                      '("DrawMLeaderOrderType" 1)
                      '("EnableBlockRotation" -1)
                      '("EnableBlockScale" -1)
                      '("EnableDogleg" -1)
                      '("EnableFrameText" 0)
                      '("EnableLanding" -1)
                      '("FirstSegmentAngleConstraint" 0)
                      '("LandingGap" 0.2)
                      '("LeaderLineType" 1)
                      
;;;	'("LeaderLineTypeId" "ByBlock") ;_ "Continuous"
                      '
                       ("LeaderLineTypeId" "Continuous") ;_ "ByBlock"
                      '("LeaderLineWeight" 30)
                      
;;;Вес линий выноски
                      '
                       ("MaxLeaderSegmentsPoints" 2)
                      '("ScaleFactor" 1.0)
                      '("SecondSegmentAngleConstraint" 0)
                      '("TextAlignmentType" 0)
                      '("TextAngleType" 0)
                      '("TextHeight" 1.5) ;_Высота текста
                      '("TextLeftAttachmentType" 3)
                      '("TextRightAttachmentType" 3)
                      '("TextString" "")
                      (list "TextStyle" (getvar "TEXTSTYLE"))
                    ) ;_ end of list
;;;(terpri)(princ item)
        (vlax-put-property newldrstyle (car item) (cadr item))
      ) ;_ end of foreach
      newldrstyle
    ) ;_ end of progn
  ) ;_ end of if
)
(defun mip-mleader-style-create-dxf (mleaderstylename dimblk)
;;;mleaderstylename - string mleader style name
;;;dimblk - Arrow Symbol block name (or nil - none)
;;;;          "."                = Closed FIlled
;;;;         "_ARCHTICK" 	= Architectural tick
;;;;         "_BOXBLANK" 	= Box
;;;;         "_BOXFILLED" 	= Box filled
;;;;         "_CLOSED" 	= Closed
;;;;         "_CLOSEDBLANK"= Closed blank
;;;;         "_DATUMBLANK" = Datum triangle
;;;;         "_DATUMFILLED"= Datum triangle filled
;;;;         "_DOT"	 = Dot
;;;;         "_DOTBLANK" 	= Dot blank
;;;;         "_DOTSMALL" 	= Dot small
;;;;         "_SMALL" 	= Dot small blank
;;;;         "_INTEGRAL" 	= Integral
;;;;         "_NONE" 	= None
;;;;         "_OBLIQUE" 	= Oblique
;;;;         "_OPEN" 	= Open
;;;;         "_OPEN30" 	= Open 30
;;;;         "_ORIGIN" 	= Origin indicator
;;;;         "_ORIGIN2" 	= Origin indicator 2
;;;;         "_OPEN90" 	= Right angle
;;;Use
;;; (mip-mleader-style-create-dxf "test-DOT" "_Dot")
;;; (mip-mleader-style-create-dxf "test-Open30" "_Open30")
;;; (mip-mleader-style-create-dxf "test-ClosedFilled" ".") ;_Closed filled
;;; (mip-mleader-style-create-dxf "test-nil" nil) ;_Not
  (vl-catch-all-apply
    '(lambda (/ tb tb-dic xr)
       ;;Добавляем стиль мультивыноски 
       (if
         (and
           (getvar "CMLEADERSTYLE") ;_Автокад поддерживает мультивыноски
           (setq tb-dic (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE")) ;_Существует словарь мультивыносок
           (not (member (cons 3 mleaderstylename)
                        (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE")
                ) ;_ end of member
           ) ;_ end of not
         )                                        ; Отсутствует стиль мультивыноски MIP
          (progn
;;;	(if (not (tblobjname "block" "_None"))
;;;	       (progn
;;;		 (setq tb (getvar "dimblk"))
;;;		 (setvar "dimblk" "_None")
;;;		 (setvar "dimblk" (if (= tb "") "." tb))
;;;		 )
;;;	       )
            (or dimblk (setq dimblk "_None"))
            (if (eq dimblk "")
              (setq dimblk ".")
            ) ;_ end of if
            (if (and dimblk (not (tblobjname "block" dimblk)))
              (progn
                (setq tb (getvar "dimblk"))
                (if
                  (vl-catch-all-error-p
                    (vl-catch-all-apply 'setvar (list "dimblk" dimblk))
                  ) ;_ end of VL-CATCH-ALL-ERROR-P
                   (setvar "dimblk" (setq dimblk "_None"))
                ) ;_ end of if
                (setvar "dimblk"
                        (if (null tb)
                          "."
                          tb
                        ) ;_ end of if
                ) ;_ end of setvar
              ) ;_ end of progn
            ) ;_ end of if
            (setq tb
                   (vl-remove-if
                     'null
                     (list
                       '(0 . "MLEADERSTYLE")
                       '(100 . "AcDbMLeaderStyle")
                       '(170 . 2)
                       '(171 . 1)
                       '(172 . 0)
                       '(90 . 2)
                       '(40 . 0.0)
                       '(41 . 0.0)
                       '(173 . 1)
                       '(91 . -1056964608)
                       '(92 . -2)
                       '(290 . 1)
                       '(42 . 0.15)
                       '(291 . 1)
                       '(43 . 0.1)
                       '(3 . "Mip-STYLE")
                       (if (tblobjname "BLOCK" dimblk)
                         (cons
                           341
                           (cdr (assoc 330 (entget (tblobjname "BLOCK" dimblk)))
                           ) ;_ end of CDR
                         ) ;_Leader ArrowID
                         nil
                       ) ;_ end of if
                       '(44 . 0.5)
                       '(300 . "")
                       '(174 . 6)
                       '(178 . 6)
                       '(175 . 1)
                       '(176 . 0)
                       '(93 . -1056964608)
                       '(45 . 1.5)
                       '(292 . 0)
                       '(297 . 0)
                       '(46 . 4.0)
                       '(94 . -1056964608)
                       '(47 . 1.0)
                       '(49 . 1.0)
                       '(140 . 1.0)
                       '(293 . 1)
                       '(141 . 0.0)
                       '(294 . 1)
                       '(177 . 0)
                       '(142 . 1.0)
                       '(295 . 1)
                       '(296 . 0)
                       '(143 . 0.125)
                       (cons 342 (tblobjname "style" (getvar "TEXTSTYLE"))) ;_Стиль

;;; Символ на конце
;;;    	    (cons 341 (cdr
;;;			(assoc 330
;;;			       (entget
;;;				 (tblobjname "block" "_None") ; _dot
;;;				 ) ;_ end of entget
;;;			       ) ;_ end of assoc
;;;			))
                     ) ;_ end of list

                   ) ;_ end of vl-remove-if
            ) ;_ end of setq
            (if (setq xr (entmakex tb))
              (dictadd (cdr (assoc -1 tb-dic)) mleaderstylename xr)
;;;  (entmod (append tb-dic(list (cons 3 "MIP")(cons 350 xr))))
            ) ;_ end of if
          ) ;_ end of progn
       ) ;_ end of if
;;;(setq tb (cdr(assoc 350(member (cons 3 "MIP")(DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE")))))
;;;(setq tb nil xr nil tb-dic nil )                       
     ) ;_ end of lambda
  ) ;_ end of VL-CATCH-ALL-APPLY
  mleaderstylename
)

Там в комментариях все что находил в интернете по этой теме. Если не интересует, можно удалить

Alikme · 17.06.2015, 14:53

http://www.arch-pub.com/2016-breaks-2009_10732354.html Такая же проблема походу как у меня, конфликт с AutoCAD 2015, пишет что помогла установка AutoCAD 2016... Код сейчас проверю

----- добавлено через ~10 мин. -----
defun mip-mleader-style-create-dxf - работает, а defun mip-mleader-style-create вылетает на том же месте...

Код:

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

 (vla-getinterfaceobject (vlax-get-acad-object)
                       (strcat "AutoCAD.AcCmColor."
                               (substr (getvar "acadver") 1 2)
                       ) ;_ end of strcat
                     )

VVA · 17.06.2015, 16:29

Я код из #44 проверял на 2015. 2014 у меня нет. 2016 так же стоит, но пока так, для интересу.

Alikme · 17.06.2015, 21:31

В 2015-ом у меня так же работает, а с 2014 пока никак. Поставлю 2016 - проверю, заработает в 2014 или нет.

ring · 16.05.2017, 00:43

А кто-нибудь подскажет как при создании стиля мультивыноски задать коэффициент перекрытия 1.2 (по умолчанию устанавливается 1.5) при установлении свойства TextBackgroundFill в True?

Нефтепроводчик · 16.05.2017, 00:56

Цитата:

Сообщение от ring

А кто-нибудь подскажет как при создании стиля мультивыноски задать коэффициент перекрытия 1.2 (по умолчанию устанавливается 1.5) при установлении свойства TextBackgroundFill в True?

Пример использования:

Код:

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

 
(setq ml_obj (vlax-ename->vla-object name))
	  (vlax-put-property ml_obj 'LandingGap (* 0.5 scale cor_sc))
	  (vlax-put-property ml_obj 'TextString coord)
	  (vlax-put-property ml_obj 'TextHeight (* hight_txt scale cor_sc))
	  (vlax-put-property ml_obj 'TextBackgroundFill cond_bm)
	  (setq	ml_ent	(vlax-vla-object->ename ml_obj)
		ml_list	(entget ml_ent)
		ml_list	(subst (cons 141 factor_bm) (assoc 141 ml_list) ml_list)
	  )

factor_bm - это и есть коэффициент скрытия заднего фона (factor background mask)
В общем, через точечную пару (141 ___)

Khasan_Mamaev · 20.05.2017, 17:12

Если кому то интересно, могу показать свое решение для проставления мультивыносок по блокам. Скрипт написан на IronPython в Dynamo, но может работать без Динамо, главное чтобы в системе был установлен АйронПайтон

Код:

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

[PYTHON]import System
from System import Array

from math import pi
app = System.Runtime.InteropServices.Marshal.GetActiveObject("Autocad.Application")
aDoc = app.ActiveDocument
mSp = aDoc.ModelSpace

sset = aDoc.PickfirstSelectionSet

def ptA(p,x1,y1):
	return Array[float]([p[0], p[1], p[2], p[0]+x1, p[1]+y1, p[2]])

def getAttr(x):
	return x.GetAttributes()

def tagText(x):
	return [x.TagString, x.TextString]

layText = IN[2]
mast = IN[3]
tag = IN[4]
obNam = 'AcDbBlockReference'

pos1 = IN[5]
pos2 = IN[6]
rot = IN[7]

x0 = IN[8]
y0 = IN[9]
if pos1 == False and pos2 == False:
	x1 = x0
	y1 = y0
elif pos1 == False and pos2 == True:
	x1 = x0
	y1 = -y0
elif pos1 == True and pos2 == True:
	x1 = -x0
	y1 = -y0
elif pos1 == True and pos2 == False:
	x1 = -x0
	y1 = y0

k = mast/100.0

allTable = []
for j in sset:
	if  j.ObjectName == obNam:#layText in j.Layer
		attr = getAttr(j)
		points = ptA(j.InsertionPoint,x1*k,y1*k)
		lead = mSp.AddMLeader(points, 0)
		for i in attr:
			if tagText(i)[0] == tag:
				lead.TextString = tagText(i)[1]
	if rot == True:
		lead.Rotate(j.InsertionPoint, pi/2)[/PYTHON]

Theodor · 20.07.2017, 03:15

Коллеги!
Заморочился с вопросом, можно ли силами VBA создать мультивыноску и задать ей стиль уже имеющийся в чертеже?

проверить наличие стиля в чертеже вроде удалось

Код:

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

Dim objDict As AcadDictionary
 Dim objTMP As AcadObject
 Dim StLeader As AcadMLeaderStyle
 Dim StLeaderAbsent As Boolean
 Dim Ind As Long
 StLeaderAbsent = True
 Set objDict = ThisDrawing.Dictionaries.Item("ACAD_MLEADERSTYLE") 'словарь мультивыносок
 For Ind = 0 To objDict.count - 1
  Set objTMP = objDict.Item(Ind) 
  If objTMP.ObjectName = "AcDbMLeaderStyle" Then
   Set StLeader = objTMP
   If objTMP.Name = "Моя_мультивыноска" Then
    StLeaderAbsent = False
    Exit For
   End If
  End If
 Next Ind

А вот как этот стиль присвоить быстро созданной мультивыноске - не пойму.

Вот так создаю:

Код:

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

 Dim objLeader As AcadLeader
 Dim objEntForLeader As AcadEntity
 Dim NormalPoint(2) As Double
 Dim PointsLD(0 To 5) As Double

 PointsLD(0) = 0: PointsLD(1) = 0: PointsLD(2) = 0
 PointsLD(3) = 500: PointsLD(4) = 500: PointsLD(5) = 0
 NormalPoint(0) = 500
 NormalPoint(1) = 500
 NormalPoint(2) = 0
 'создаю многострочный текст
 Set objEntForLeader = ThisDrawing.ModelSpace.AddMText(NormalPoint, 1000, "Текст")
 'создаю мультиыноску
 Set objLeader = ThisDrawing.ModelSpace.AddLeader(PointsLD, objEntForLeader, acLineNoArrow)

И получаю на выходе сразу две беды.

1. Созданная мультивыноска в принципе не хочет принимать стиль путем банального копирования свойств методами автокад. Следовательно она изначально корявая получается
2. Как программно присвоить существующий стиль к программно (и даже не программно) созданной мультивыноске

Что-то внутри меня говорит, что не все просто. Надо отдельно мучать передачу свойств (стиля) многострочного текста и отдельно самой выноске. Ошибаюсь?

Wolkodaw · 22.10.2018, 19:03

Здравствуйте, может кто-нибудь помочь - не понимаю, как вставить стандартную мультивыноску AutoCAD?
Остановился вот на чём:

Код:

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

 
; Простановка мультивыносок для выбранных блоков
; Перед началом работы убедиться, что в настройках файла выбрана мультивыноска со стилем "1"

;;;;;;;;;;;;;;;;Подготовка;;;;;;;;;;;;;;;;
; загрузка корневых элементов функций ActiveX
(vl-load-com)
(setq acad_application (vlax-get-acad-object))
(setq active_document (vla-get-ActiveDocument acad_application))
(setq model_space (vla-get-ModelSpace active_document))
(setq paper_space (vla-get-PaperSpace active_document))

; создание переменных и списков, используемых в программе
(setq i -1)
(setq ars_blocks_list (list))

; Запрос масштаба у пользователя
(initget 7)
(setq scale (getint "Введите масштаб "))
(princ "Масштаб принят")


;;;;;;;;;;;;;;;;Извлечение из чертежа исходных блоков;;;;;;;;;;;;;;;;

; создание набора блоков с фильтром на блоки
(setq ars_blocks_set (ssget '((0 . "insert"))))

; оценка количества элементов в наборе
(setq ars_blocks_set_length (sslength ars_blocks_set))

; повтор функции (начало repeat)
(repeat ars_blocks_set_length (setq i (1+ i))

; преобразование блока во VLA-объект
(setq ars_blocks_vla (vlax-ename->vla-object (ssname ars_blocks_set i)))

; добавление преобразованного блока в список
(setq ars_blocks_list (cons ars_blocks_vla ars_blocks_list))

); конец repeat

;;;;;;;;;;;;;;;;Вставка мультивыносок;;;;;;;;;;;;;;;;

; вычисление длины списка
(setq ars_blocks_length (length ars_blocks_list))

; вставка мультивыноски
(setq ars_blocks_MV (vla-AddMLeader (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) (vlax-3d-point 0 0 0) 0))

Заканчивается всё это выводом системного сообщения: "; ошибка: Ошибка Automation. Неверный список точек"

Что я делаю не так?

Сразу опишу поставленную цель (чтоб было понятнее): мультивыноска должна с блоков из созданного списка извлечь записанное ранее значение атрибута "ПОЗ" и записать его в мультивыноску. И так на все выделенные блоки. Предварительно вижу так, чтобы мультивыноски вставлялись в геометрическую середину блоков.

Кулик Алексей aka kpblc · 22.10.2018, 20:40

Все правильно. Читаем справку: нужно передавать массив точек (начало / конец - как минимум). Поставь вручную мультивыноску и сделай для нее дамп.

Vladimir_Sergeevich · 25.10.2018, 13:24

Цитата:

Сообщение от Wolkodaw

Заканчивается всё это выводом системного сообщения: "; ошибка: Ошибка Automation. Неверный список точек"

Что я делаю не так?

В случае Mleader одной точкой не отделаться, надо в один вариант сразу все точки передавать

Код:

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

 
;;pt_list - список из двух точек: начало и конец
(setq pt_variant 
	(vlax-make-variant
		(vlax-safearray-fill 
			(vlax-make-safearray 
				vlax-vbDouble 
				'(0 . 5) 
			) 
			(append (car pt_list) (cadr pt_list) 	)	
		) 	
	) 
)

yurms · 16.11.2018, 13:02

Упрямые ВЫноски!!
заходит свойство AML.TextDirection=5 -"по стилю".. и сменятся на 2=acRightToLeft не хочет? а на 3-без проблем
что за стиль мешает этому ? в стилях мультивыносок галочка снята

этот вопрос поднимался в посте #23 ☆ и ниже.. но понятного ответа я не узрел..

Код:

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

Set AML = acadDoc.ModelSpace.AddMLeader(points, xx) 'вставляем примитив в автокад и заполняем ниже его свойства

     If startPnt(0) <= endPnt(0) Then
                            AML.TextDirection = acLeftToRight ' с лева на право прекрасно работает
                            Else
'                            почему нельзя присвоить значение привязки выноски с правой стороны?
                           AML.TextDirection = acRightToLeft     ' с права на лева - вызывает ошибку
                           AML.TextDirection = acTopToBottom  'c верху в низ- прекрасно работает
                            End If

Кулик Алексей aka kpblc · 16.11.2018, 17:37

Вручную поменяй выравнивание и посмотри, какие свойства сменились.
ИМХО выравнивание текста (то бишь аннотации) здесь совсем не при делах. Могу ошибаться - давно с мультивыносками не работал...

posetitel · 05.02.2025, 11:49

Подниму тему.
Товарищи, подскажите, пожалуйста, как на VBA реализовать мультивыноску, чтобы текс в выноске сразу же отображался на экране, а вот конечное положение выноски можно было бы выбрать самому (например, в зависимости от длины текста). Для иллюстрации прилагаю гифку.
Требуемый функционал в примере реализован на лисп, но разобраться как именно и как это переложить на VBA никак не могу.

posetitel · 05.02.2025, 16:44

сам себе отвечу:
скорее всего стандартного метода нет, нужно писать отдельную функцию

Theodor · 05.02.2025, 21:07

Цитата:

Сообщение от posetitel

Товарищи, подскажите, пожалуйста, как на VBA реализовать мультивыноску, чтобы текс в выноске сразу же отображался на экране, а вот конечное положение выноски можно было бы выбрать самому (например, в зависимости от длины текста). Для иллюстрации прилагаю гифку.

Я, что-то, не понял задачи. Описание и гифка точно об одном и том же?

Сергей812 · 05.02.2025, 21:08

Цитата:

Сообщение от posetitel

скорее всего стандартного метода нет

чтобы было стандартным методом (точнее, стандартными средствами ЯП) - надо переходить на более "свежие" ЯП. Например, .Net

posetitel · 05.02.2025, 21:23

Theodor, точно об одном и том же. Попробуй нажать на миниатюру, тогда в полном размере будет видно, как текст выноски можно смещать вместе с курсором и выбирать, куда лучше разместить на чертеже.
Сергей812, прогулялся по ссылке, там как раз то, что нужно, но написано, опять же, через функцию. Через отдельную функцию и на лиспе было реализовано. Я то полагал, что это можно просто одним параметром указать при вызове мультивыноски, ну либо какую переменную в автокаде поменять.

Сергей812 · 05.02.2025, 21:31

Цитата:

Сообщение от posetitel

прогулялся по ссылке, там как раз то, что нужно, но написано, опять же, через функцию.

но реализовано на основе готового EntityJig базового класса, а не через пользовательские костыли.

posetitel · 05.02.2025, 21:54

сразу не въехал, спасибо, присмотрюсь

posetitel · 06.02.2025, 19:24

Похоже, такого функционала на VBA и не реализовать в принципе.
На лиспе можно, на С# можно, а вот на VBA нет

Сергей812 · 06.02.2025, 19:39

Цитата:

Сообщение от posetitel

Похоже, такого функционала на VBA и не реализовать в принципе.

VBA в МС-офисе родной, в акаде он прикручен сбоку через одно место. Даже не загрузить готовый VBA проект в акад без установленной среды разработки VBA - в отличие от остальных ЯП для разработки надстроек. Поэтому ничего удивительного, что в VBA не полный доступ ко всему API акада (хотя лисп тоже не полный доступ дает, но на нем хотя бы имитацию jig можно сделать).

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Программное создание размерных стилей	Кулик Алексей aka kpblc	Программирование	96	21.02.2025 13:53
Программное создание PlotConfiguration	Sleekka	Программирование	2	17.09.2008 20:48
NanoСПДС	gest	Другие CAD системы	401	15.07.2008 14:50
Программное создание vport`ов	Ax3	Программирование	10	29.08.2007 16:02