LISP. Пересоздать выбранную мультивыноску

kacugu · 23.02.2019, 19:22

Доброго времени суток.
Возникла необходимость привести к одному виду кучу файлов. При редактировании стилей мультивыносок выяснилось, что у большинства мультивыносок свойства отредактированы вручную. Самым простым способом сбросить свойства таких мультивыносок показалось создание новой мультивыноски на основе старой Offtop: насколько знаю, до сих пор в Autocad нет возможности сбросить свойства мультивынок на свойства по стилю.

Получилось слепить из найденного на просторах следующий код:

Код:

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

 ;; Лисп создаёт мультивыноску, со свойствами выбранной мультивыноски

;;  Добавить:
;; 1 - Обработчик ошибок
;; 2 - vla-StartUndoMark
;; 3 - Возможность обрабатывать сразу несколько мультивыносок (ssget...)
;; 4 - Обработку нескольких вершин выноски
;; 5 - Добавление аннотативных масштабов исходного объекта
;; 6 - Обработку мультивыносок без выносок
;; 7 - Разобраться с положением создаваемого текста

(defun c:Kacugu-Recreate-Mleader
(/ 
ent
entdata
layer
VertexCoord
DogCoord
TextCoord
obj
getLay
getStyle
getTxtRot
getTxtStr
getTxtWidth
getTxtDir
getDoglegDir
lstptslen
newMld
i
points
lst
safe
safe-fill
)

(vl-load-com)

;; Выбор мультивыноски
(while
	(progn
	(setvar 'errno 0)
	(setq ent (car (entsel "\nВыберите мультивыноску <Выход>: "))) 
		(cond
			(
			 	(= 7 (getvar 'errno))
				(princ "\nМимо, попробуйте снова.")
			)
			(
				(null ent)
				nil
			)
			(
				(/= "MULTILEADER" (cdr (assoc 0 (setq entdata (entget ent)))))
				(princ "\nОбъект не является мультивыноской.")
			)
		);; end of cond
	);; end of progn
);; end of while

(setq VertexCoord (MleaderCoordsGet ent)
DogCoord (cdr (assoc 10 (cdr (member '(302 . "LEADER{") entdata))))
TextCoord (cdr (assoc 10 entdata))
obj (vlax-ename->vla-object ent)
getLay (vla-get-Layer obj)
getStyle (vla-get-StyleName obj)
getTxtWidth (vla-get-TextWidth obj)
getTxtStr (vla-get-TextString obj)
getTxtRot (vla-get-TextRotation obj)
getTxtDir (vla-get-TextDirection obj)
getDoglegDir (vla-GetDoglegDirection obj 0)  
lstptslen (length VertexCoord)
i 0)

(progn
	(setq newMld
		(vlax-invoke
			(vlax-get-property (LM:acdoc)
				(if (= 1 (getvar 'cvport))
					'paperspace
					'modelspace
				)
			)
			'addmleader
			(append (nth 0 VertexCoord) DogCoord)
			0
		)
	)

	(if (<= (car DogCoord) (car (trans (nth 0 VertexCoord) ent 1)))
		(progn
			(vla-setdoglegdirection newMld 0 (vlax-3D-point (trans '(-1.0 0.0) 1 0 t)))
			(vlax-invoke newMld 'setleaderlinevertices 0 (append (nth 0 VertexCoord) DogCoord))
		)
		(progn
			(vla-setdoglegdirection newMld 0 (vlax-3D-point (trans '(1.0 0.0) 1 0 t)))
		)
	);; end of if

 	(vla-put-textstring newMld getTxtStr)
	(vla-put-StyleName newMld getStyle)
	(vla-put-TextRotation newMld getTxtRot)
  	(vla-put-TextDirection newMld getTxtDir)
	(vla-put-Layer newMld getLay)
	(if (/= getTxtWidth 0)
	(vla-put-TextWidth newMld getTxtWidth))
	;;;	(entdel ent)
  
	(repeat (- lstptslen 1)
	  	(setq i (1+ i))
		(setq lst (append (nth i VertexCoord) DogCoord)) ;;http://adn-cis.org/forum/index.php?topic=7529.msg23985#msg23985
		(setq safe (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length lst)))))
		(setq safe-fill (vlax-safearray-fill safe lst))
		(vla-AddLeaderLineEx newMld safe-fill)
	) ;; end of repeat 
);; end of progn

(princ)
  
);; end of defun




;;;https://www.theswamp.org/index.php?topic=48967.msg541497#msg541497
;;; Возвращает список с координатами главных вершин мультивыноски
(defun MleaderCoordsGet ( ename / elist return)
	;; (setq ename (car (entsel)))
	(setq elist (entget ename))
	(while (setq elist (cdr (member '(304 . "LEADER_LINE{") elist)))
		(setq return (cons (cdr (assoc 10 elist)) return))
	)
	(reverse return)
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object
 
(defun LM:acdoc nil
   (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
   (LM:acdoc)
)

Минимум действий он выполняет. Но не получается разобраться с положением текста: новый текст часто создаётся со смещением (на картинке жёлтым цветом исходная мультивыноска, белым - новая).
Как это можно исправить?

update от 2019-02-28
в общем получилось что-то такое:

Код:

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

 
;; Recreate mleader

;; thanx 3dwannab for idea https://www.cadtutor.net/forum/topic/43221-set-mleader-to-existing-mleader-style-via-lisp/?tab=comments#comment-547617

;;  TODO:
;; - work with mleaders on locked layer (yes/no)

(defun c:kaa-Recreate-Mleader-2D
(/
*error*
acDoc
old_osmode
layer
islock
ss1
sel
cnt
ent
entdata
obj
obj-Last-Leader-Line-Point  
obj-Content-Base-Position
obj-Clusters-Count
obj-Layer
obj-Style
obj-TxtStr
obj-TxtWidth
obj-TxtBackFill
obj-TxtDir
obj-TxtJustify
obj-TxtRot
obj-Dogleg-Length
obj-Clusters
obj-First-Cluster
obj-Dogleg-Dir
obj-First-Leader-Line-Index
obj-First-Leader-Line-Vertex
newMld
obj-Leader-Line-Indexes
obj-Leader-Line-Vertices
obj-All-Leader-Line-Vertices
il
obj-tmp-Coor-X
new-tmp-Coor-X
)

(vl-load-com)

(vla-startundomark
	(setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
) ;_ end of vla-startundomark
  
(defun *error* (errmsg)
	(and errmsg
		(not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
		(princ (strcat "\n<< Error: " errmsg " >>\n"))
	)
	(setvar 'osmode old_osmode)
  	(vla-put-lock layer islock)
);; end of defun

(setq layer (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) (getvar "clayer")))
(setq islock (vla-get-lock layer))
(if (eq islock :vlax-true) (vla-put-lock layer :vlax-false))
  
(setq old_osmode (getvar "osmode"))
(setvar "osmode" 0)
(setq ss1 (ssget ":L" '((0 . "MULTILEADER"))))
(setq sel (ssadd))
(setq cnt 0)

(repeat (setq cnt (sslength ss1))

	(setq cnt (1- cnt))
	(setq ent (cdr (assoc -1 (entget (ssname ss1 cnt)))))
  	(setq entdata (entget ent))
	(setq obj (vlax-ename->vla-object ent))
	(setq obj-Clusters-Count (vla-get-LeaderCount obj))
	(setq obj-Layer (vla-get-Layer obj))
	(setq obj-Style (vla-get-StyleName obj))
	(setq obj-TxtWidth (vla-get-TextWidth obj))
	(setq obj-TxtStr (vla-get-TextString obj))
	(setq obj-TxtRot (vla-get-TextRotation obj))
	(setq obj-TxtDir (vla-get-TextDirection obj))
	(setq obj-TxtBackFill (vla-get-TextBackgroundFill obj))
  	(setq obj-TxtJustify (vla-get-textjustify obj))
  	(setq obj-Dogleg-Length (vla-get-dogleglength obj))

	(cond
		(
			(> obj-Clusters-Count 0)
		  	(progn
				(setq obj-Last-Leader-Line-Point   (cdr (assoc 10 (cdr (member '(302 . "LEADER{") entdata)))))
				(setq obj-Content-Base-Position  (cdr (assoc 10 entdata)))
			  	(setq obj-Clusters (MleaderClustersGet ent)) ;; cluster's index list
				(setq obj-First-Cluster (nth 0 obj-Clusters))
			  	(setq obj-Dogleg-Dir (vla-GetDoglegDirection obj obj-First-Cluster))
			  	(setq obj-First-Leader-Line-Index (nth 0 (vl-sort (kaa-var-to-list (vla-getleaderlineindexes obj obj-First-Cluster)) '<)))
				(setq obj-First-Leader-Line-Vertex (vla-getleaderlinevertices obj obj-First-Leader-Line-Index));; all leader line vertices 
				(setq newMld
					(vlax-invoke
						(vlax-get-property (LM:acdoc)
							(if (= 1 (getvar 'cvport))
								'paperspace
								'modelspace
							)
						)
						'addmleader
						(kaa-var-to-list obj-First-Leader-Line-Vertex)
						0
					)
				);; end of setq
			  
			  	(vla-put-Layer newMld obj-Layer)
			  	(vla-put-textstring newMld obj-TxtStr)
			  	(vla-put-TextRotation newMld obj-TxtRot)
				(vla-put-TextDirection newMld obj-TxtDir)
			  	(vla-put-Textjustify newMld obj-TxtJustify)
			  	(if (/= obj-TxtWidth 0) (vla-put-TextWidth newMld obj-TxtWidth))
				(vla-put-TextBackgroundFill newMld obj-TxtBackFill)
			  
				(if (/= obj-First-Cluster 0) (setq obj-Clusters (vl-sort obj-Clusters '<)) (vla-removeleader newmld 0))
				
				(setq obj-All-Leader-Line-Vertices (list 'txt))
				
				(foreach i obj-Clusters
				  	(setq obj-Leader-Line-Indexes (vl-sort (kaa-var-to-list (vla-getleaderlineindexes obj i)) '<))
					(foreach  il obj-Leader-Line-Indexes
				  		(progn
							(setq obj-Leader-Line-Vertices (vla-getleaderlinevertices obj il))
							(if (not (member (kaa-var-to-list obj-Leader-Line-Vertices) obj-All-Leader-Line-Vertices))
								(progn 
									(setq obj-All-Leader-Line-Vertices (cons (kaa-var-to-list obj-Leader-Line-Vertices) obj-All-Leader-Line-Vertices))
									(vla-addleaderlineex newMld obj-Leader-Line-Vertices)
								);; end of progn
							);; end of if
						);; end of progn
					);; end of foreach
				);; end of foreach		  	
			  	
  			  	(vla-setdoglegdirection newMld (nth 0 (MleaderClustersGet (vlax-vla-object->ename newmld))) (vlax-variant-value obj-Dogleg-Dir))
				(vla-setleaderlinevertices newMld
			  				(nth 0 (kaa-var-to-list (vla-getleaderlineindexes newmld (nth 0 (MleaderClustersGet (vlax-vla-object->ename newmld))))))
			  				(vlax-variant-value obj-First-Leader-Line-Vertex))
			  	(if (/= obj-First-Cluster 0) (vla-removeleaderline newmld 0))
			  
			  	(vla-put-StyleName newMld obj-Style)
				(RN_MatchAnntScale (vlax-vla-object->ename obj) (vlax-vla-object->ename newmld))
				(entdel ent)
			);; end of progn
		 )
		(
			(= obj-Clusters-Count 0)
		 	(progn
			  	(setq obj-Content-Base-Position  (cdr (assoc 10 entdata)))
			  	(setq obj-tmp-Coor-X (nth 0 obj-Content-Base-Position ))
			  	(setq new-tmp-Coor-X (+ obj-tmp-Coor-X (* obj-Dogleg-Length -1)))
			  	(setq obj-Content-Base-Position  (list new-tmp-Coor-X (nth 1 obj-Content-Base-Position ) (nth 2 obj-Content-Base-Position )))
			  	(setq newMld
					(vlax-invoke
						(vlax-get-property (LM:acdoc)
							(if (= 1 (getvar 'cvport))
								'paperspace
								'modelspace
							)
						)
						'addmleader
						(append (list 0.0 0.0 0.0) obj-Content-Base-Position )
						0
					)
				)
			  	
			  	(vla-put-Layer newMld obj-Layer)
			  	(vla-put-textstring newMld obj-TxtStr)
			  	(if (/= obj-TxtWidth 0) (vla-put-TextWidth newMld obj-TxtWidth))
				(vla-put-TextRotation newMld obj-TxtRot)
				(vla-put-TextDirection newMld obj-TxtDir)
			  	(vla-put-Textjustify newMld obj-TxtJustify)
				(vla-put-TextBackgroundFill newMld obj-TxtBackFill)
			  	(vla-removeleaderline newmld 0)
			  	(vla-put-StyleName newMld obj-Style)
			  	(RN_MatchAnntScale (vlax-vla-object->ename obj) (vlax-vla-object->ename newmld))
				(entdel ent)
			);; end of progn
		)
	);; end of cond
);; end of repeat

(setvar "osmode" old_osmode)
(vla-put-lock layer islock)
  
(vla-endundomark acDoc) ; undomark bottom mark
(*error* nil) (princ)
  
);; end of defun

;;;хххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххх

;;;хххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххх


;;;https://www.theswamp.org/index.php?topic=48967.msg541497#msg541497
;;; Returns list of mleader's cluster

(defun MleaderClustersGet ( ename / elist return)
	(setq elist (entget ename))
	(while (setq elist (cdr (member '(302 . "LEADER{") elist)))
		(setq return (cons (cdr (assoc 90 elist)) return))
	)
	(reverse return)
)

;;;хххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххх

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object
 
(defun LM:acdoc nil
   (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
   (LM:acdoc)
)
;;;хххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххх

;; variant to list
 
(defun kaa-var-to-list (source)
   (vlax-safearray->list (vlax-variant-value source))
)

;;;хххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххх

;; http://forum.dwg.ru/showpost.php?p=1573413&postcount=47
;;_RN_MatchAnntScale - Копируем аннотативный масштаб (масштабы)
;;_с одного объекта на другой (другие). По сути это Match Properties,
;;_но только для аннотативных масштабов.
;;; Match Properties for annotative scales

(defun RN_MatchAnntScale ( sourceobj  destinationobj / sourceann sourceannlist pr gr cmd adoc scale)
	(vl-load-com)
	(vla-startundomark
		(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
	) ;_ end of vla-startundomark
	(sssetfirst nil nil)
	(if
		(and
			(setq sourceann sourceobj)
			(IsAnnotative sourceann)
			(setq sourceannlist (GetAnnoScales sourceann))
			(setq destinationobj (ssadd destinationobj))
		)
		(foreach scale sourceannlist
			(progn
				(setq cmd (getvar "CMDECHO"))
				(vl-cmdf "_-objectscale" destinationobj "" "_Add" scale "")
				(command)
			);; end of progn
		);; end foreach
	)
(vla-endundomark adoc) ; undomark bottom mark
(princ)
);defun

;;;хххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххх

  (defun GetAnnoScales (e / dict lst rewind res)
;;; Argument: the ename of an annotative object.
;;; Returns the annotative scales associated with the 
;;; ename as a list of strings.
;;; Example: ("1:1" "1:16" "1:20" "1:30")
;;; Returns nil if the ename is not annotative. 
;;; Can be used to test whether ename is annotative or not.
;;; Works with annotative objects: text, mtext, leader, mleader, 
;;; dimension, block reference, tolerance and attribute.
;;; Based on code by Ian Bryant.


;;;Joe Burk
;;;http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-do-i-make-hatch-annotative-via-vlisp-almost-there/m-p/2080831    
;; Argument: an ename or vla-object.
;; Return T if object is annotative, otherwise nil.
;;;(defun IsAnnotative (e)
;;;(if (not (eq (type e) 'ENAME))
;;;(setq e (vlax-vla-object->ename e))
;;;)
;;;(if (assoc -3 (entget e '("AcadAnnotative"))) T)
;;;)

;;;(defun IsAnnotative (e)
;;;(and e
;;;(setq e (cdr (assoc 360 (entget e))))
;;;(setq e (dictsearch e "AcDbContextDataManager"))
;;;(setq e (dictsearch (cdr (assoc -1 e)) "ACDB_ANNOTATIONSCALES"))
;;;(assoc 350 e)
;;;)
;;;)
    (if
      (and
        e
        (setq dict (cdr (assoc 360 (entget e))))
        (setq lst (dictsearch dict "AcDbContextDataManager"))
        (setq lst
               (dictsearch (cdr (assoc -1 lst)) "ACDB_ANNOTATIONSCALES")
        ) ;_ end of setq
        (setq dict (cdr (assoc -1 lst)))
      ) ;_ end of and
       (progn
         (setq rewind t)
         (while (setq lst (dictnext dict rewind))
           (setq e      (cdr (assoc 340 lst))
                 ;; res    (cons (cdr (assoc 300 (entget e))) res)
                 rewind nil
           ) ;_ end of setq
         ) ;_ end of while
       ) ;_ end of progn
    ) ;_ end of if
    (reverse res)
  ) ;_end

;;;хххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххх

(defun IsAnnotative (e)
	(and e
		(setq e (cdr (assoc 360 (entget e))))
		(setq e (dictsearch e "AcDbContextDataManager"))
		(setq e (dictsearch (cdr (assoc -1 e)) "ACDB_ANNOTATIONSCALES"))
		(assoc 350 e)
	)
)

;;;хххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххх

(princ)
(princ "\n:: команда kaa-Recreate-Mleader-2D - ”Recreate selected mleaders ::")
(princ)

update от 2020-12-18
Offtop: Вспомнилось, обновил код. Что конкретно менял - уже не вспомню.
По-прежнему следует использовать программку на свой риск и страх.

update от 2021-01-18
Версия 4.2. Поля и спецсимволы теперь должны сохраняться Offtop: я надеюсь

Кулик Алексей aka kpblc · 23.02.2019, 19:43

На какой картинке?

----- добавлено через ~2 мин. -----
Также не помешает хотя бы элементарный пример.
И не проще ли будет прочитать настройки стиля для мультивыноски и принудительно назначить соответствующие свойства?

kacugu · 23.02.2019, 20:19

Цитата:

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

На какой картинке?

добавил

Цитата:

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

И не проще ли будет прочитать настройки стиля для мультивыноски и принудительно назначить соответствующие свойства?

Если правильно помню, то при ручных изменениях свойств мультивыноски в её описание добавляются новые dxf-коды с описанием этих изменений (проверил сейчас. при изменении указателя мультивыноски добавляется dxf (342 . <Entity name: 243b6fc1f50>). Т.е. помимо принудительного назначения свойств ещё надо удалить и эти dxf.

kacugu · 28.02.2019, 13:08

Обновил код в шапке темы

Barmaley Bubusikin · 18.01.2021, 01:53

А так чтобы не удалялись поля и спецсимволы в тексте мвыноски возможно?

kacugu · 18.01.2021, 03:51

Цитата:

Сообщение от Barmaley Bubusikin

А так чтобы не удалялись поля и спецсимволы в тексте мвыноски возможно?

Попробуйте версию 4.2, вроде работает

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Не работает lisp на autocad 2014. Lisp предназначен для изменения порядкового номера листа	vladykinalex	LISP	28	14.07.2023 19:27
Lisp. Не вставляет значения в базу access.	Zaghim	LISP	2	11.07.2012 14:29
Умер разработчик языка программирования Lisp	andr_g	LISP	1	27.10.2011 08:36
{Конкурс} Lisp. Задачки для студентов	gomer	LISP	10	05.01.2011 16:33
загрузка DOS прог через LISP	Gaa	LISP	15	12.08.2005 19:19