Преобразование текста и линий в мультивыноски (чохом)

casaatik · 02.03.2015, 15:41

Добрый день.
Лисп приведенный ниже преобразует текст в мультивыноску, но делает он это по одному за раз. Как можно его изменить чтобы он сам находил линии с текстом и делал из них мультивыноски. Есть файлы где изначально были мультивыноски, потом их взорвали и получили мтексты с отрезками. Хотелось бы обратно все в мультивыноски в несколько кликов. Пример исходного файла во вложении.

Код:

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

(defun c:mt2ml ( / oobj nobj nstrg)
  (vl-load-com)
  (setq oobj (vlax-ename->vla-object (car (nentsel "\nSelect source text: "))))
  (if (= (vlax-get-property oobj 'ObjectName) "AcDbMText")
    (setq nstrg (vlax-get-property oobj 'TextString))
    (exit)	   
    )
  (command "_MLEADER")
  (while (= 1 (logand (getvar "CMDACTIVE") 1)) (command PAUSE))
  (setq nobj (vlax-ename->vla-object (entlast)))
  (if (= (vlax-get-property nobj 'ObjectName) "AcDbMLeader")
    (vlax-put-property nobj 'TextString nstrg)
    (exit)	   
    )
  (entdel (vlax-vla-object->ename oobj))
  (princ)
)

Do$ · 02.03.2015, 16:02

Цитата:

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

Как можно его изменить чтобы он сам находил линии с текстом и делал из них мультивыноски.

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

DmitriyBastr · 04.12.2015, 11:55

Если тема ещё актуальна.....
Сам с эти столкнулся.
Могу только такое решение предложить:

1. Соединяем два отрезка в выноску и кликаем в пространстве чертежа, что бы не заполнять поле текста. Вот код для этого:

Код:

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

 (defun c:tt ()
 (setvar "CMDECHO" 0)
 (if (setq ss (ssget '((0 . "LINE")))) (progn
 (setq i -1)
 (repeat (sslength ss)
 (setq ent (entget (ssname ss (setq i (1+ i))))
 p1 (cdr(assoc 10 ent))
 p2 (cdr(assoc 11 ent)))
 (command "_.LEADER" p1 p2 "" "" "N")
 )
 (command "_.ERASE" ss "")
 ))
 (setvar "CMDECHO" 1)
 (princ)
 )

2. Соединяем полученную пустую выноску с нужным текстом. И получается готовая мультивыноска. Вот код для этого:

Код:

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

[lisp][/;LEADER2MULTILEADER
;Converts autocad leaders with text or mtext to autocad 2008+ multileaders
;created by Jeffery Allen - 11/1/2007
 (defun C:LD2MLD (/ ent1 ent1-gcode ent1-type leader-pt-list leader-1st-pt leader-2nd-pt
ent2 ent2-gcode ent2-type text-strg)
 (setq ent1(car(entsel "\nSelect a Leader: "))
ent1-gcode(entget ent1)
ent1-type(cdr(assoc 0 ent1-gcode))
)
(if(= ent1-type "LEADER")
(progn
(setq leader-pt-list(member(assoc 10 ent1-gcode) ent1-gcode)
leader-1st-pt(cdr(car leader-pt-list))
leader-2nd-pt(cdr(cadr leader-pt-list))
ent2(car(entsel "\nSelect Text or Mtext: "))
ent2-gcode(entget ent2)
ent2-type(cdr(assoc 0 ent2-gcode))
)
(if(or(= ent2-type "TEXT")(= ent2-type "MTEXT"))
(progn
(setq text-strg(cdr(assoc 1 ent2-gcode)))
(setvar "OSMODE" (boole 7 (getvar "OSMODE") 16384));osnap off
(setvar "CMDECHO" 0);command echo off
(command "_.ERASE" ent1 ent2 ""
"_.MLEADER" leader-1st-pt leader-2nd-pt text-strg
)
(setvar "CMDECHO" 1);command echo on
(setvar "OSMODE" (boole 2 (getvar "OSMODE") 16384));osnap on
)
)
(if(and(/= ent2-type "TEXT")(/= ent2-type "MTEXT"))(alert "Object selected is not a text or mtext"))
)
)
(if(/= ent1-type "LEADER")(alert "Object selected is not a leader"))
(princ)
);defun
 (setq message "Leader 2 Multileader loaded...
 Converts autocad leaders with text or
mtext to autocad 2008+ multileaders
 Created by Jeffery Allen - 11/1/2007
 Start command with \"LD2MLD\"")
(alert message)
(setq message nil)
(princ)
(c:LD2MLD) LISP]

3.Есть ещё предположение, что эти два кода можно как-то объединить...

Konstnt16 · 24.01.2025, 10:56

Какая жалость что тема заглохла.
Та же задача стоит. Но что легче что расчлененная выноска в блоке находится.

ssn · 24.07.2025, 11:31

По моему запросу когда то писался вот такой лисп.
Что он делает.
В программе Автодеск Инвентор нет возможности настроить нормальные выноски в два этажа.
По этому, в автокаде приходилось править эти выноски. Выноски состояли из двух дуг, двух текстов и двух линий. Приложил картинку.
Лисп преобразует эти выноски в мультивыноску в два яруса. Работает пакетно. Мне очень помогает.
Понимаю, сам по себе лисп очень индивидуален, но возможно поможет понять, что и как делается

Код:

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

  ;******************************************************
 ;PSW - 2015  E-mail homepsw@gmail.com
 ;******************************************************
(defun C:PSW  (/ A1 A2 CENTR DD DUGA ED EN I J KL LAY M1
	       M2 N N1 N2 NNN OBJ P1 P2 POINT RAD SLOY SS
	       SSSS T1 T2 TE1 TE2 U1 U2 W1 W2 OLD CEN DIS SER)
 ;******************************************************
(vl-load-com)    
 (setq Old (getvar "OsMode"))
 (Setvar "CMDECHO" 0)
 (setvar "CLAYER" "Обозначение (ISO)")
   (prompt "\nВыберите рамкой объекты: ")
	(setq SSSS (ssget))
(if (= SSSS Nil) (progn (alert "Нет дуг на слое <Обозначение (ISO)> для обработки выносок!") (exit))) ; если объектов нет завершаем работу
    (setq NNN (sslength SSSS))
 ;*************************************************
(setvar "CLAYER" "Обозначение (ISO)") ; слой должен существовать  
    (setq j 0)
    (setq KL 0)
    (repeat NNN ; Цикл по всем выбранным дугам
        (setq A1 (ssname SSSS j))
        (setq j (+ 1 j))
        (setq A2 (entget A1))
        (setq Duga  (cdr (assoc 0 A2))) ;  дуга
        (setq Sloy  (cdr (assoc 8 A2))) ;  дуга
      
(if (and (= DUGA "ARC") (= Sloy   "Обозначение (ISO)") )
  (progn
        (setq Rad   (cdr (assoc 40 A2))) ; Радиус
        (setq Centr (cdr (assoc 10 A2))) ; центр дуги
        (setq U1    (cdr (assoc 50 A2))) ; угол 1
        (setq U2    (cdr (assoc 51 A2))) ; угол 2
     (if (> U1 U2)
	(progn
        (setq W1    (polar Centr 3.92699  (* (sqrt 2.0) Rad)))
        (setq W2    (polar Centr 0.785398 (* (sqrt 2.0) RAd)))
      ;(command "_LINE" (list 0.0 0.0 0.0) W2 "")
  ;(command "_ZOOM" "_ALL")	
   (setq SS (ssget "_C" W1 W2))
;;;;;;;;;	(command "__rectang" W1 W2 )
	;(command "_ZOOM" "О" SS "")
	;(command "_REGEN" )
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@  
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@  
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@  
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@  
   (setq N (sslength SS))
        (setq I 0)
    (setq Te1 " ")
    (setq Te2 " ")
    (Repeat N
	(setq EN (ssname SS I))
        (setq ED (entget EN))
    	(setq Obj (cdr (assoc 0 ED)))
    	(setq LAY (cdr (assoc 8 ED)))
        (setq Point (cdr (assoc 10 ED)))
                ;********************************************************
		(if (= Obj "ARC")
		  (progn
		            (setq CEN (cdr (assoc 10 ED))) ; центр дуги
        		    (setq SER (seredina W1 W2))
		            (setq Dis (distance Ser Point))
        	            (setq Rad (cdr (assoc 40 ED))) ; Радиус
	
		  	(if (< DIS RAD) (entdel en))
		  ))
      		;********************************************************
      		(if (and (= Obj "LINE") (= LAY "Обозначение (ISO)")) (progn
		  (setq T1 (cdr (assoc 10 ED)))
		  (setq T2 (cdr (assoc 11 ED)))
		  	(if ( = (cadr T1) (cadr T2)) (setq P1 T1 P2 T2))
		        (if (/= (cadr T1) (cadr T2)) (setq N1 T1 N2 T2))
		  	(entdel en)
		      ))
                 ;********************************************************
		(if (and (= Obj "MTEXT")(= LAY "Обозначение (ISO)") (> (cadr Point) (cadr Centr)))
		  (setq TE1 (cdr (assoc 1 ED))))
		(if (and (= Obj "MTEXT")(= LAY "Обозначение (ISO)") (< (cadr Point) (cadr Centr)))
		  (setq TE2 (cdr (assoc 1 ED))))

                (if (= Obj "MTEXT") (entdel en))
        (setq i (+ i 1))
    ); REPEAT
  ;########################################################################
  (setq dd 0.0)
  	(if (> (distance P1 N1) dd ) (setq dd (distance P1 N1) M1 N1 M2 P2))
        (if (> (distance P2 N1) dd ) (setq dd (distance P2 N1) M1 N1 M2 P1))
  	(if (> (distance P1 N2) dd ) (setq dd (distance P1 N2) M1 N2 M2 P2))
        (if (> (distance P2 N2) dd ) (setq dd (distance P1 N2) M1 N2 M2 P1))
	(Setvar "OsMode" 0)
  (command "_MLEADER" M1 M2 (strcat TE1 "\n" TE2) )
	    (setq b (vlax-ename->vla-object (entlast)))
            (vlax-put-property b   'TextJustify  2)
(Setvar "OsMode" Old)

;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@  
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@  
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
	)); if (> U1 U2)
    ))
); REPEAT NNN

  (Setvar "OsMode" Old)
     (SetVar "FILEDIA" 1) (princ)
 ) ; END DEFUN





 ;************************************************************************
 ; Функция возвращает: Точку середины отрезка Т1 Т2
 ; Параметр  - точки Т1 Т2
 ;************************************************************************
(defun SEREDINA (TE1 TE2 / _AA _DX _DY _DZ)
    (setq _DX (/ (+ (car TE1) (car TE2)) 2.0))
    (setq _DY (/ (+ (cadr TE1) (cadr TE2)) 2.0))
    (setq _DZ 0.0)
    (if (and (/= (caddr TE1) NIL) (/= (caddr TE2) NIL))
        (progn
            (setq _DZ (/ (+ (caddr TE1) (caddr TE2)) 2.0))
        )
    )
    (setq _AA (list _DX _DY _DZ))
) ;END DEFUN
 ;************************************************************************

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Программное создание размерных стилей	Кулик Алексей aka kpblc	Программирование	96	21.02.2025 13:53
Создание нового типа линий	Apelsinov	AutoCAD	915	08.07.2022 12:36
Как удалить тип линии	Tolyanovich	AutoCAD	48	20.11.2014 09:24
Преобразование многострочного текста в блок с атрибутами	superkot007	Программирование	16	21.03.2014 15:26
LISP. Выравнивание текста по двум точкам.	Krieger	Готовые программы	10	24.12.2011 16:02