Нужен LISP для суммы длин отрезков линни

ilka_t · 26.02.2004, 10:13

Подскажити где можно скачать или поделитись если у кого есть такое.

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

koMon · 24.04.2018, 21:38

Loolik, если коротенько обобщить, то длину каких примитивов нужно считать и в какие вставлять? По мне, так лучше выстругать новые грабли)

Loolik · 25.04.2018, 10:06

koMon, постараюсь перефразировать)
Собственно, взят код из поста 104.
Добавляю в конце команду:
Len2ET - вставка результата функции EntLen в существующий Текст/МТекст/Ячейку таблицы/Атрибут/МВыноску. Эта команда работает как положено, за исключением вставки текста в ячейку таблицы с пустым текстом. Своими силами исправить ошибку не смогу

Код:

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

 
;;Команда вставки в существующий текст результата вычислений суммы примитивов
;;с преварительным указанием масштабного коэффициента
(defun c:Len2ET	 ()
  (initget 6)
  (setq mmss t)
  (while mmss
    (setq *MIP-MODEMACRO-SCALE*
	   (if (null (setq mms_temp (getreal (strcat "\nНовый масштабный коэффициент: <"
						     (if *MIP-MODEMACRO-SCALE*
						       (rtos *MIP-MODEMACRO-SCALE*)
						       ""
						       ) ;_ конец if
						     ">: "
						     ) ;_ конец strcat
					     ) ;_ конец getreal
			   ) ;_ конец setq
		     ) ;_ конец null
	     *MIP-MODEMACRO-SCALE*
	     mms_temp
	     ) ;_ конец if
	  mmss (if *MIP-MODEMACRO-SCALE*
		 nil
		 t
		 ) ;_ конец if
	  ) ;_ конец setq
    ) ;_ конец while
  (C:ENTLEN)
  (C:LPE)
  ) ;_ конец defun Len2ET

Интуитивно понимаю, что не работает эта часть кода

Код:

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

 
(defun TTC_Paste(pasteStr keepText / nslLst vlaObj )
(if (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки <выход>: "))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE


;;Length Print to Existing text
(defun c:LPE ( )
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." ","  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 nil))
(princ)
) ;_ конец defun LPE

koMon · 25.04.2018, 11:13

Вот. Вы Entlen-ом суммарную длину каких-то определённых примитивов считаете, ну там отрезок, полилиния..? Потому как Entlen из #104, по ходу, будет считать всё, что считается.

Loolik · 25.04.2018, 11:31

Цитата:

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

Потому как Entlen из #104, по ходу, будет считать всё, что считается.

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

VVA · 25.04.2018, 12:13

Цитата:

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

Интуитивно понимаю, что не работает эта часть кода

Добавлена опция "Точка"

Код:

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

(defun TTC_Paste(pasteStr keepText / nslLst vlaObj tstyle txt pt tblobj lst tblset row col )
 ;;; keepText - t  -  сохранить текст
 ;;;         - nil - заменить текст
 ;;;         - "Точка" - вставить в ячейку таблицы
(if (eq keepText  "Точка")(setq nslLst keepText keepText nil))
(or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
(initget "Точка")
(if (or (eq nslLst "Точка")
        (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки [Точка для пустой ячейки] <выход>: "))
        )
(progn (cond
((eq nslLst "Точка")
 (setvar "cmdecho" 0)
(setq tstyle (getvar "TEXTSTYLE")) ;_Стиль текста Стиль должен существовать
    ;_ Создаем текст
(if (= (cdr (assoc 40 (tblsearch "STYLE" tstyle))) 0.0)
     ;; нулевая высота текста
   (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) *TEXTSIZE* 0 pasteStr)
   (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) 0 pasteStr)
   ) ;_ end of if
    (setq txt (entlast))
  ;_ Копируем в буфер и обратно
  (vl-cmdf "_updatefield" txt "")
  (princ "\n Укажите точку вставки текста или ячейку таблицы:")
  (vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
  ;_ В txt примитив текста в pt точка вставки  
  (setq txt (entlast) pt (getvar "LASTPOINT"))
(or
    (and ;_Проверяем, попала ли точка в ячейку таблицы
      (setq  tblobj nil tblset (ssget "_X" (list '(0 . "ACAD_TABLE")(cons 410 (getvar "CTAB")))))
      (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
      (progn
        (vl-catch-all-apply '(lambda()
        (mapcar '(lambda (x)
           (or tblobj
               (and
                 (= :vlax-true (vla-HitTest x
                               (vlax-3d-point (trans pt 1 0))
                               (vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
                               'row 'col))
                 (setq tblobj x)
                 )
               )
           )
        lst)
                               )
          )
        tblobj
        )
       row col
      (or (vla-SetText tblobj row col pasteStr) t)
      (entdel txt)
      )
    (and ;_Не попала, рисуем текст с полем
      (setq txt (vlax-ename->vla-object txt))
      (vlax-write-enabled-p txt)
      (vlax-method-applicable-p txt 'FieldCode) ;_есть метод FieldCode
      (vlax-property-available-p txt 'TextString)
      (vlax-put txt 'TextString pasteStr)
      )
    )
  )         
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF" "MULTILEADER"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4

(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE

Loolik · 25.04.2018, 13:07

Цитата:

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

Добавлена опция "Точка"

Спасибо, но результат выполнения "Точка для пустой ячейки" создает новый текстовый примитив.
А возможно реализовать вставку текста именно в пустую ячейку таблицы, причем без дополнительного выбора в контекстном меню? Т.е. чтобы TTC_Paste понимала, что я выбрал либо текстосодержащий объект (МТекст, Текст, Артибут, ЯчейкуТаблицыСТекстом), либо ПустуюЯчейкуТаблицы?

VVA · 25.04.2018, 14:06

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

Цитата:

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

Точка для пустой ячейки" создает новый текстовый примитив

Ну так и ткни им в пустую ячейку и посмотри на результат

Loolik · 25.04.2018, 14:19

Цитата:

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

Ну так и ткни им в пустую ячейку и посмотри на результат

Происходит создание текста поверх таблицы. В содержимое ячейки ничего не вписывается. Проверял на AutoCAD 2009x86, AutoCAD 2015x64.

VVA · 25.04.2018, 16:55

Цитата:

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

Происходит создание текста поверх таблицы.

Исправил #205

Loolik · 26.04.2018, 17:45

VVA, спасибо за помощь, работает отлично.
Осталась последняя хотелка, но затыкаюсь в одном месте.
Программингом не владею, делаю свою команду по подобию, которая будет делать следующее:

Задаю пользовательский масштабный коэффициент
Выполняю подсчет длин примитивов
Указываю на выбор режим вставки результата /Новый текст/Существующий текст/Пустая ячейка таблицы/

Так вот затык получается при попытке выполнить вставку в пустую ячейку

Код:

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

(COMMAND (c:LPE) "_Точка")

Код:

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

(defun c:Len2TX1 (/ *ans* )
   ;; Задаем пользовательский масштабный коэффициент:
   (initget 6)
   (setq mmss t)
   (while mmss
      (setq *MIP-MODEMACRO-SCALE*
         (if (null 
               (setq mms_temp 
                  (getreal
                     (strcat "\nНовый масштабный коэффициент: <"
                        (if *MIP-MODEMACRO-SCALE* (rtos *MIP-MODEMACRO-SCALE*) "") ;_ конец if
                        ">: "
                     ) ;_ конец strcat
                  ) ;_ конец getreal
               ) ;_ конец setq
            ) ;_ конец null
            *MIP-MODEMACRO-SCALE* mms_temp
         ) ;_ конец if
         mmss (if *MIP-MODEMACRO-SCALE* nil t) ;_ конец if
      ) ;_ конец setq
   ) ;_ конец while
   ;; Выполняем подсчет длин примитивов
   (C:ENTLEN)
   ;; Определяем тип вставки результата
   (initget "Новый Существующий ПустЯчейкаТаблицы")
   (setq *ans*
      (cond
        (
          (getkword
            (strcat "\nРезультат в /Новый Текст/Существующий Текст/Пустую Ячейку Таблицы/ [Новый/Существующий/ПустЯчейкаТаблицы]<"
              (setq *ans*
                (cond ( *ans* ) ( "Новый" ))
              ) ">: "
            )
          )
        )
      )
    )
    (if (= *ans* "Новый") (c:LPN)
        (if (= *ans* "Существующий") (c:LPE) 
            (COMMAND (c:LPE) "_Точка")
        )
    )
) ; конец defun c:Len2TX1

VVA · 26.04.2018, 18:12

Loolik, Так не пойдет. Я обновил #205 еще раз. Добавил возможность передать параметр "Точка" (почитай коментарии в начале)
Соответственно для вставки в ячейку таблицы своя команда

Код:

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

;;Length Print to Table sell
(defun c:LPT ( )
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." ","  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 "Точка"))
(princ))

Loolik · 27.04.2018, 00:20

Цитата:

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

Я обновил #205 еще раз. Добавил возможность передать параметр "Точка" (почитай коментарии в начале)
Соответственно для вставки в ячейку таблицы своя команда

Огромное спасибо за помощь, все работает отлично! А вставка в МВыноску по умолчанию не предусмотрена? В принципе, это мне и не требуется.
Вдруг кому пригодится результат - запускать командой LEN2TX

Код:

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

(vl-load-com)
;;Задание глобальных переменных с параметрами вставки текста
(if (null *MIP-MODEMACRO-HTXT*) (setq *MIP-MODEMACRO-HTXT* 300)) ;_Высота текста 300 единиц
(if (null *MIP-MODEMACRO-RTOS*) (setq *MIP-MODEMACRO-RTOS* -1.0)) ;_Округление -1-LUPREC
(if (null *MIP-MODEMACRO-SCALE*) (setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштабный коэффициент 1
(vl-propagate '*MIP-MODEMACRO-HTXT*)
(vl-propagate '*MIP-MODEMACRO-RTOS*)
(vl-propagate '*MIP-MODEMACRO-SCALE*)
(defun C:entLen (/ set:entities int:allEntities int:curveEntities int:l rea:length)
  (princ "\nТекущий коэффициент K=")
  (princ (vl-princ-to-string *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst)))) ; Этот if добавлен для 
    (setq set:entities (ssget)) ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities
    (progn
      (setq 
        int:allEntities (sslength set:entities) ; количество выбранных примитивов 
        int:curveEntities 0 ; счетчик линейных примитивов 
        int:l 0 ; счетчик 
        rea:length 0.0 ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities))
        (if
          (not
            (vl-catch-all-error-p
              (vl-catch-all-apply 'vlax-curve-getstartpoint
                (list
                  (vlax-ename->vla-object (ssname set:entities int:l))
                ) ;_ list 
              ) ;_  vl-catch-all-apply 
            ) ;_  vl-catch-all-error-p 
          ) ;_  not 
          (setq int:curveEntities (1+ int:curveEntities)
            rea:length (+ rea:length (vlax-curve-getdistatparam 
                                       (vlax-ename->vla-object (ssname set:entities int:l))
                                       (vlax-curve-getendparam (ssname set:entities int:l)))) ;_  + 
          ) ;_  конец setq 
        ) ;_  конец if
        (setq int:l (1+ int:l))
      ) ; конец  while
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (princ 
        (strcat "\n Выбрано примитивов: "
          (itoa int:allEntities) 
          ", из них линейных: "
          (itoa int:curveEntities)
          "\nПоправочный коэфиициент K="
          (rtos *MIP-MODEMACRO-SCALE* 2 2)
          "\n Общая длина линейных примитивов: "
          (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0) (getvar "LUPREC") *MIP-MODEMACRO-RTOS*) ;_ конец if
           ) ;_ конец rtos
        ) ;_ конец strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны! Будет использован последний результат")
  ) ;_  if 
  (prin1)
) ;_ конец defun entLen


;;Задание глобальных переменных 
(defun c:MM  (/ buf)
  ;;Масштабный коэффициент
  (initget 7)
  (setq *MIP-MODEMACRO-SCALE* (getreal "\nНовый масштабный коэффициент: "))
  ;;Высота текста
  (initget 6)
  (princ "\nВысота текста <")
  (princ *MIP-MODEMACRO-HTXT*)
  (princ ">: ")
  (if (setq buf (getdist))
    (setq *MIP-MODEMACRO-HTXT* buf)
  ) ;_ конец if
  ;;Точность округления
  (initget 4 "L")
  (princ "\nТочность округления [Luprec] <")
  (if (< *MIP-MODEMACRO-RTOS* 0)
    (princ "Luprec")
    (princ *MIP-MODEMACRO-RTOS*)
  ) ;_ конец if
  (princ ">: ")
  (if (setq buf (getint))
    (setq *MIP-MODEMACRO-RTOS*
      (if (numberp buf)
        buf
        -1
      ) ;_ конец if
    ) ;_ конец setq
  ) ;_ конец if
  (vl-propagate '*MIP-MODEMACRO-HTXT*)
  (vl-propagate '*MIP-MODEMACRO-RTOS*)
  (vl-propagate '*MIP-MODEMACRO-SCALE*)
  (princ)
) ;_ конец defun MM

;;Вставка результата в текст или таблицу
(defun TTC_Paste (pasteStr keepText / nslLst vlaObj tstyle txt pt tblobj lst tblset row col )
;; keepText - t  -  сохранить текст
;;         - nil - заменить текст
;;         - "Точка" - вставить в ячейку таблицы
  (if (eq keepText  "Точка")
    (setq nslLst keepText keepText nil)
  );_ конец if
  (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
  (initget "Точка")
  (if 
    (or (eq nslLst "Точка")
      (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки [Точка для пустой ячейки] <выход>: "))
    )
    (progn 
      (cond
      ;  start condition #1
        (
          (eq nslLst "Точка")
          (setvar "cmdecho" 0)
          (setq tstyle (getvar "TEXTSTYLE")) ;_Стиль текста Стиль должен существовать
          ;_ Создаем текст
          (if (= (cdr (assoc 40 (tblsearch "STYLE" tstyle))) 0.0)
            ;; нулевая высота текста
            (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) *TEXTSIZE* 0 pasteStr)
            (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) 0 pasteStr)
          ) ;_ end of if
          (setq txt (entlast))
          ;_ Копируем в буфер и обратно
          (vl-cmdf "_updatefield" txt "")
          (princ "\n Укажите точку вставки текста или ячейку таблицы:")
          (vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
          ;_ В txt примитив текста в pt точка вставки  
          (setq txt (entlast) pt (getvar "LASTPOINT"))
          (or
            (and ;_Проверяем, попала ли точка в ячейку таблицы
              (setq  tblobj nil tblset (ssget "_X" (list '(0 . "ACAD_TABLE")(cons 410 (getvar "CTAB")))))
              (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
              (progn
                (vl-catch-all-apply 
                  '(lambda()
                    (mapcar 
                      '(lambda (x)
                        (or tblobj
                          (and
                            (= :vlax-true 
                              (vla-HitTest x
                                (vlax-3d-point (trans pt 1 0))
                                (vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
                                'row 'col
                              )
                            )
                            (setq tblobj x)
                          )
                        )
                      )
                      lst
                    )
                  )
                )
                tblobj
              ) ; end progn
              row col
              (or (vla-SetText tblobj row col pasteStr) t)
              (entdel txt)
            ) ; end and
            (and ;_Не попала, рисуем текст с полем
              (setq txt (vlax-ename->vla-object txt))
              (vlax-write-enabled-p txt)
              (vlax-method-applicable-p txt 'FieldCode) ;_есть метод FieldCode
              (vlax-property-available-p txt 'TextString)
              (vlax-put txt 'TextString pasteStr)
            ) ; end and
          ) ; end or
        ) ; end condition #1

        ; start condition #2
        (
          (and (= 4 (length nslLst))
            (= "DIMENSION" (cdr(assoc 0(entget(car(last nslLst))))))
          ); end and
          (setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
          (setq oldStat (vla-get-Measurement vlaObj))
          (if keepText
            (if (= (vla-get-TextOverride vlaObj) "")
            (setq pasteStr (strcat
              pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) 
              (vla-get-PrimaryUnitsPrecision vlaObj)))
            ) ; end setq
            (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj))))
          ) ; end if
          (if 
            (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
            (princ "\n Can't paste. Object may be on locked layer. ")
          ) ; end if
        ); end condition #2

        ; start condition #3
        (
          (and (= 4(length nslLst))
            (= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))
          ); end and
          (setq vlaObj (vlax-ename->vla-object(car nslLst)))
          (if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
          (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
            (princ "\nError. Can't pase text. ") (entupd (car(last nslLst)))
          ) ; end if
        ); end condition # 3

        ; start condition #4
        (
          (and (= 4(length nslLst))
            (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))
          ); end and
          (princ "\nCan't paste to block's DText or MText. ")
        ); end condition #4

        ; start condition #5
        (
          (and (= 2(length nslLst))
            (member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF" "MULTILEADER"))
          ); end and
          (setq vlaObj (vlax-ename->vla-object(car nslLst)))
          (if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
          (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
            (princ "\nError. Can't pase text. ")
          ) ; end if
        ); end condition #5

        ; start condition #6
        (T (princ "\nCan't paste. Invalid object. ")); end condition #6
      ); end cond
    T); end progn
  nil); end if
);_TTC_PASTE


;;Length Print to Existing text
(defun c:LPE ( )
  (and (= (type *MIP-LENGTH*) 'REAL)
    (TTC_Paste 
      (vl-string-translate "." "," 
        (rtos *MIP-LENGTH* 2
          (if (< *MIP-MODEMACRO-RTOS* 0)
            (getvar "LUPREC")
            *MIP-MODEMACRO-RTOS*
          )
        )
      )
      nil
    )
  )
  (princ)
) ;_ конец defun LPE
  

;;Length Print to New text
(defun c:LPN  ()
  (if (= (type *MIP-LENGTH*) 'REAL)
    (progn
      (vla-addtext
        (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
        (vl-string-translate "." "," 
          (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0) 
              (getvar "LUPREC") 
              *MIP-MODEMACRO-RTOS*
            ) ;_ конец if
          ) ;_ конец rtos
        ) ;_ конец vl-string-translate
       (vlax-3d-point '(0 0 0))
       *MIP-MODEMACRO-HTXT*
      ) ;_ конец vla-addtext
      (princ "\n Укажите точку вставки текста:")
      (command "_.copybase" '(0 0 0) (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause)
      ) ;_ конец progn
    ) ;_ конец if
  (princ)
) ;_ конец defun LPN


;;Length Print to Table sell
(defun c:LPT ( )
  (and (= (type *MIP-LENGTH*) 'REAL)
    (TTC_Paste (vl-string-translate "." ","  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
    "Точка")
  )
  (princ)
) ;_ конец defun LPT


;;(princ "\nНаберите в командной строке:
;;          \nEntLen - подсчет примитивов
;;          \nMM - масштабный коэффициент и настройка
;;          \nLPN - результат в новый текст
;;          \nLPE - результат в существующий текст или заполненную ячейку
;;          \nLPT - результат в пустую ячейку таблицы")
;;(princ)

;;Команда вставки нового текста с результатом вычислений суммы примитивов
;;с преварительным указанием масштабного коэффициента и выбором формата конечного результата
;;либо | Новый текст | Cуществующий текст или заполненная ячейка таблицы | Пустая ячейка таблицы |
(defun c:Len2TX (/ *ans* )
   ;; Задаем пользовательский масштабный коэффициент:
   (initget 6)
   (setq mmss t)
   (while mmss
      (setq *MIP-MODEMACRO-SCALE*
         (if (null 
               (setq mms_temp 
                  (getreal
                     (strcat "\nНовый масштабный коэффициент: <"
                        (if *MIP-MODEMACRO-SCALE* (rtos *MIP-MODEMACRO-SCALE*) "") ;_ конец if
                        ">: "
                     ) ;_ конец strcat
                  ) ;_ конец getreal
               ) ;_ конец setq
            ) ;_ конец null
            *MIP-MODEMACRO-SCALE* mms_temp
         ) ;_ конец if
         mmss (if *MIP-MODEMACRO-SCALE* nil t) ;_ конец if
      ) ;_ конец setq
   ) ;_ конец while
   ;; Выполняем подсчет длин примитивов
   (C:ENTLEN)
   ;; Определяем тип вставки результата
   (initget "Новый Существующий ПустЯчейкаТаблицы")
   (setq *ans*
      (cond
        (
          (getkword
            (strcat "\nРезультат в |_Новый Текст_|_Существующий Текст_|_Пустую Ячейку Таблицы_|" "\n[Новый/Существующий/ПустЯчейкаТаблицы]<"
              (setq *ans*
                (cond ( *ans* ) ( "Новый" ))
              ) ">: "
            )
          )
        )
      )
    )
    (if (= *ans* "Новый") (c:LPN)
        (if (= *ans* "Существующий") (c:LPE) 
            (c:LPT)
        )
    )
) ; конец defun c:Len2TX

VVA · 27.04.2018, 10:57

Цитата:

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

А вставка в МВыноску по умолчанию не предусмотрена

Когда писалась эта программа мультивыносок не было как класса. Обновил #205 Правки минимальные (добавить "MULTILEADER" в перечень)

Цитата:

(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF" "MULTILEADER"))); end and

Loolik · 27.04.2018, 11:11

Спасибо!

Цитата:

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

Обновил #205

Обновил #212

koMon · 25.05.2018, 17:35

Loolik,
я-таки, в промежутках между, выстругал альтернативные к-рабли)...

Loolik · 25.05.2018, 22:27

koMon, Спасибо огромное, очень добротная реализация с богатым функционалом! Не хватает лишь кнопки "Создать новый текст" на самый искушенный случай)

koMon · 25.05.2018, 22:43

Цитата:

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

Не хватает лишь кнопки "Создать новый текст" на самый искушенный случай)

Для нового текста нужно кликнуть туда, где хочешь его создать, то есть нужно не зацепить то, во что можно вставить сумму)

Loolik · 26.05.2018, 01:23

Тогда крайне удобные получились грабли) Спасибо!

koMon · 26.05.2018, 15:48

Loolik,
Happy husing!-)
Хочу отметить, что проверок на заблокированность текущего слоя, слоёв объектов, выбранных для вставки суммы не производится, то есть вполне возможно аварийное завершение команды. Новый текст вставляется в кликнутую точку с в текущем слое с текущим стилем и высотой 5 единиц.

Опции темы	Поиск в этой теме
Версия для печати Отправить по электронной почте	Поиск в этой теме: Расширенный поиск

26.02.2004, 10:13
Нужен LISP для суммы длин отрезков линни ilka_t Москва Регистрация: 20.01.2004 Сообщений: 154 Подскажити где можно скачать или поделитись если у кого есть такое. Полилиния не подходит т.к. эти отрезки разбросаны по всему чертежу, а надобы выбрав несколько линий узнать их общую длинну.
Просмотров: 117351