CAD БИБЛИОТЕКА
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > LISP. Пересоздать выбранную мультивыноску

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

Ответ
Поиск в этой теме
Непрочитано 23.02.2019, 19:22 #1
LISP. Пересоздать выбранную мультивыноску
kacugu
 
начинающий инженер-гидротехник
 
Санкт-Петербург
Регистрация: 18.04.2010
Сообщений: 787

Доброго времени суток.
Возникла необходимость привести к одному виду кучу файлов. При редактировании стилей мультивыносок выяснилось, что у большинства мультивыносок свойства отредактированы вручную. Самым простым способом сбросить свойства таких мультивыносок показалось создание новой мультивыноски на основе старой 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: я надеюсь

Миниатюры
Нажмите на изображение для увеличения
Название: для форума.png
Просмотров: 74
Размер:	86.7 Кб
ID:	211288  

Вложения
Тип файла: dwg
DWG 2013
Для форума.dwg (37.3 Кб, 16 просмотров)
Тип файла: lsp KAA_Recreate_MLeader.lsp (10.9 Кб, 32 просмотров)
Тип файла: lsp KAA_Recreate_MLeader_v4.1.lsp (7.3 Кб, 8 просмотров)
Тип файла: lsp KAA_Recreate_MLeader_v4.2.lsp (11.0 Кб, 6 просмотров)


Последний раз редактировалось kacugu, 18.01.2021 в 03:51. Причина: обновил код
Просмотров: 2238
 
Непрочитано 23.02.2019, 19:43
| 1 #2
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 38,069


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

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

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 23.02.2019, 20:19
#3
kacugu

начинающий инженер-гидротехник
 
Регистрация: 18.04.2010
Санкт-Петербург
Сообщений: 787


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
На какой картинке?
добавил

Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
И не проще ли будет прочитать настройки стиля для мультивыноски и принудительно назначить соответствующие свойства?
Если правильно помню, то при ручных изменениях свойств мультивыноски в её описание добавляются новые dxf-коды с описанием этих изменений (проверил сейчас. при изменении указателя мультивыноски добавляется dxf (342 . <Entity name: 243b6fc1f50>). Т.е. помимо принудительного назначения свойств ещё надо удалить и эти dxf.
kacugu вне форума  
 
Автор темы   Непрочитано 28.02.2019, 13:08
#4
kacugu

начинающий инженер-гидротехник
 
Регистрация: 18.04.2010
Санкт-Петербург
Сообщений: 787


Обновил код в шапке темы
kacugu вне форума  
 
Непрочитано 18.01.2021, 01:53
#5
Barmaley Bubusikin


 
Регистрация: 05.06.2014
Сообщений: 54


А так чтобы не удалялись поля и спецсимволы в тексте мвыноски возможно?
Barmaley Bubusikin вне форума  
 
Автор темы   Непрочитано 18.01.2021, 03:51
#6
kacugu

начинающий инженер-гидротехник
 
Регистрация: 18.04.2010
Санкт-Петербург
Сообщений: 787


Цитата:
Сообщение от Barmaley Bubusikin Посмотреть сообщение
А так чтобы не удалялись поля и спецсимволы в тексте мвыноски возможно?
Попробуйте версию 4.2, вроде работает
kacugu вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > LISP. Пересоздать выбранную мультивыноску

Система Техэксперт дает уверенность в правильности и эффективности принимаемых инженерных решений!
Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Не работает lisp на autocad 2014. Lisp предназначен для изменения порядкового номера листа vladykinalex LISP 17 25.05.2020 21:09
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