| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

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

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

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

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

Полилиния не подходит т.к. эти отрезки разбросаны по всему чертежу, а надобы выбрав несколько линий узнать их общую длинну.
Просмотров: 140457
 
Непрочитано 24.04.2018, 21:38
#201
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,665


Loolik, если коротенько обобщить, то длину каких примитивов нужно считать и в какие вставлять? По мне, так лучше выстругать новые грабли)
koMon вне форума  
 
Непрочитано 25.04.2018, 10:06
#202
Loolik


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


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
  
Loolik вне форума  
 
Непрочитано 25.04.2018, 11:13
#203
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,665


Вот. Вы Entlen-ом суммарную длину каких-то определённых примитивов считаете, ну там отрезок, полилиния..? Потому как Entlen из #104, по ходу, будет считать всё, что считается.
koMon вне форума  
 
Непрочитано 25.04.2018, 11:31
#204
Loolik


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


Цитата:
Сообщение от koMon Посмотреть сообщение
Потому как Entlen из #104, по ходу, будет считать всё, что считается.
Именно это и нужно - считать всю возможную геометрию (полилинии, сплайны, дуги, отрезки, окружности). Чертежи могут оказаться чужими, а разбираться какими примитивами вычерчено не очень хочется.
Loolik вне форума  
 
Непрочитано 25.04.2018, 12:13
1 | #205
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Цитата:
Сообщение от 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
__________________
Как использовать код на Лиспе читаем здесь

Последний раз редактировалось VVA, 27.04.2018 в 10:55. Причина: Добавлена мультивыноска ("MULTILEADER")
VVA вне форума  
 
Непрочитано 25.04.2018, 13:07
#206
Loolik


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


Цитата:
Сообщение от VVA Посмотреть сообщение
Добавлена опция "Точка"
Спасибо, но результат выполнения "Точка для пустой ячейки" создает новый текстовый примитив.
А возможно реализовать вставку текста именно в пустую ячейку таблицы, причем без дополнительного выбора в контекстном меню? Т.е. чтобы TTC_Paste понимала, что я выбрал либо текстосодержащий объект (МТекст, Текст, Артибут, ЯчейкуТаблицыСТекстом), либо ПустуюЯчейкуТаблицы?
Loolik вне форума  
 
Непрочитано 25.04.2018, 14:06
#207
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


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

Цитата:
Сообщение от Loolik Посмотреть сообщение
Точка для пустой ячейки" создает новый текстовый примитив
Ну так и ткни им в пустую ячейку и посмотри на результат
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 25.04.2018, 14:19
#208
Loolik


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


Цитата:
Сообщение от VVA Посмотреть сообщение
Ну так и ткни им в пустую ячейку и посмотри на результат
Происходит создание текста поверх таблицы. В содержимое ячейки ничего не вписывается. Проверял на AutoCAD 2009x86, AutoCAD 2015x64.

Последний раз редактировалось Loolik, 25.04.2018 в 14:27.
Loolik вне форума  
 
Непрочитано 25.04.2018, 16:55
1 | #209
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Цитата:
Сообщение от Loolik Посмотреть сообщение
Происходит создание текста поверх таблицы.
Исправил #205
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 26.04.2018, 17:45
#210
Loolik


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


VVA, спасибо за помощь, работает отлично.
Осталась последняя хотелка, но затыкаюсь в одном месте.
Программингом не владею, делаю свою команду по подобию, которая будет делать следующее:
  1. Задаю пользовательский масштабный коэффициент
  2. Выполняю подсчет длин примитивов
  3. Указываю на выбор режим вставки результата /Новый текст/Существующий текст/Пустая ячейка таблицы/
Так вот затык получается при попытке выполнить вставку в пустую ячейку
Код:
[Выделить все]
(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
Loolik вне форума  
 
Непрочитано 26.04.2018, 18:12
1 | #211
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


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))
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 27.04.2018, 00:20
#212
Loolik


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


Цитата:
Сообщение от 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

Последний раз редактировалось Loolik, 27.04.2018 в 11:07. Причина: Добавлена обработка МВыносок
Loolik вне форума  
 
Непрочитано 27.04.2018, 10:57
1 | #213
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Цитата:
Сообщение от Loolik Посмотреть сообщение
А вставка в МВыноску по умолчанию не предусмотрена
Когда писалась эта программа мультивыносок не было как класса. Обновил #205 Правки минимальные (добавить "MULTILEADER" в перечень)
Цитата:
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF" "MULTILEADER"))); end and
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 27.04.2018, 11:11
#214
Loolik


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


Спасибо!
Цитата:
Сообщение от VVA Посмотреть сообщение
Обновил #205
Обновил #212
Loolik вне форума  
 
Непрочитано 25.05.2018, 17:35
2 | #215
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,665


Loolik,
я-таки, в промежутках между, выстругал альтернативные к-рабли)...
Миниатюры
Нажмите на изображение для увеличения
Название: Get_Total_Length.gif
Просмотров: 132
Размер:	3.07 Мб
ID:	202731  
Вложения
Тип файла: lsp Get_Total_Length_2.lsp (33.3 Кб, 75 просмотров)
koMon вне форума  
 
Непрочитано 25.05.2018, 22:27
#216
Loolik


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


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

Последний раз редактировалось Loolik, 25.05.2018 в 22:35.
Loolik вне форума  
 
Непрочитано 25.05.2018, 22:43
#217
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,665


Цитата:
Сообщение от Loolik Посмотреть сообщение
Не хватает лишь кнопки "Создать новый текст" на самый искушенный случай)
Для нового текста нужно кликнуть туда, где хочешь его создать, то есть нужно не зацепить то, во что можно вставить сумму)
koMon вне форума  
 
Непрочитано 26.05.2018, 01:23
#218
Loolik


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


Тогда крайне удобные получились грабли) Спасибо!
Loolik вне форума  
 
Непрочитано 26.05.2018, 15:48
#219
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,665


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

Последний раз редактировалось koMon, 26.05.2018 в 15:55.
koMon вне форума  
 
Непрочитано 10.09.2019, 10:22
#220
Tyhig

Оснащение проходки горных выработок, ПОС, нормоконтроль, КР, АР
 
Блог
 
Регистрация: 30.01.2008
Ленинград
Сообщений: 18,620


На мой взгляд это был самый лучший вариант от Mike - lisp для суммирования длин линий отрезков полилиний и т.п.
Сколько же вы тут написали...

Ключевые слова.
Макрос, длина линий, длина отрезков, длина полилиний, Lsum , Mike - lisp , tyhig (мой ник только ключевое слово для поиска).

Цитата:
Сообщение от ;14569
;******************************************************************************
;
; Lsum -функция определяет суммарные длинну и площадь набора линий и полилиний
;
;******************************************************************************
(defun C:lsum (/ cmdold nabor nl i j prima sum_line sum_pline asum_pline pt_list)
(vl-load-com)
(setq cmdold (getvar "cmdecho"))
(setvar "cmdecho" 0)
(princ "\n Выберите линии и 2D-полилинии:\n")
(if (eq nil (setq nabor (ssget '((-4 . "<OR")
(0 . "line")
(0 . "lwpolyline")
(-4 . "OR>")
) ) ) )
(progn
(princ "***** Среди указаных объектов ни линий, ни 2D-полилиний НЕТ! *****\n")(textscr)(princ)
)
(progn
(setq nl (sslength nabor))
(setq i nl j 0 sum_line 0 sum_pline 0 asum_pline 0)
(while (< 0 i)
(setq i (1- i))
(setq prima (ssname nabor i))
(if (eq "LWPOLYLINE" (cdr (assoc 0 (entget prima))))
(progn
(command "_AREA" "_o" (ssname nabor i))
(setq sum_pline (+ sum_pline (getvar "Perimeter")))
(if (or (eq 1 (cdr (assoc 70 (entget prima))))
(equal (assoc 10 (entget prima)) (assoc 10 (reverse (entget prima))))
)
(setq asum_pline (+ asum_pline (getvar "Area")))
)
)
(progn
(setq sum_line (+ sum_line (vla-get-length (vlax-ename->vla-object prima))))
(setq pt_list (append pt_list (cdr (assoc 10 (entget prima))) (cdr (assoc 11 (entget prima)))))
(setq j (1+ j))
)
)
)
(setvar "cmdecho" cmdold)
(textscr)
(princ " Выбрано: Линий - ")(princ j)(princ "; Полилиний - ")(princ (- nl j))(princ ".\n")
(princ " Сумма длин линий - ")(princ sum_line)(princ "\n")
(princ " Суммарный периметр полилиний - ")(princ sum_pline)(princ "\n")
(princ " Сумма площадей \"замкнутых\" полилиний - ")(princ asum_pline)(princ "\n")
(princ)
)
)
)




(princ "\n Загружена утилита Lsum,\n")
(princ " вычисляющая сумму длин линий и суммарный периметр полилиний,\n")
(princ " для \"замкнутых\" полилиний вычисляется сумма площадей.\n")
(princ " Для работы с утилитой введите в командной строке Lsum.\n")
(textscr)
(princ)

;******************************************************************************
;
; Lsum -функция определяет суммарные длинну и площадь набора линий и полилиний
;
;******************************************************************************
(defun C:lsum (/ cmdold nabor nl i j prima sum_line sum_pline asum_pline pt_list)
(vl-load-com)
(setq cmdold (getvar "cmdecho"))
(setvar "cmdecho" 0)
(princ "\n Выберите линии и 2D-полилинии:\n")
(if (eq nil (setq nabor (ssget '((-4 . "<OR")
(0 . "line")
(0 . "lwpolyline")
(-4 . "OR>")
) ) ) )
(progn
(princ "***** Среди указаных объектов ни линий, ни 2D-полилиний НЕТ! *****\n")(textscr)(princ)
)
(progn
(setq nl (sslength nabor))
(setq i nl j 0 sum_line 0 sum_pline 0 asum_pline 0)
(while (< 0 i)
(setq i (1- i))
(setq prima (ssname nabor i))
(if (eq "LWPOLYLINE" (cdr (assoc 0 (entget prima))))
(progn
(command "_AREA" "_o" (ssname nabor i))
(setq sum_pline (+ sum_pline (getvar "Perimeter")))
(if (or (eq 1 (cdr (assoc 70 (entget prima))))
(equal (assoc 10 (entget prima)) (assoc 10 (reverse (entget prima))))
)
(setq asum_pline (+ asum_pline (getvar "Area")))
)
)
(progn
(setq sum_line (+ sum_line (vla-get-length (vlax-ename->vla-object prima))))
(setq pt_list (append pt_list (cdr (assoc 10 (entget prima))) (cdr (assoc 11 (entget prima)))))
(setq j (1+ j))
)
)
)
(setvar "cmdecho" cmdold)
(textscr)
(princ " Выбрано: Линий - ")(princ j)(princ "; Полилиний - ")(princ (- nl j))(princ ".\n")
(princ " Сумма длин линий - ")(princ sum_line)(princ "\n")
(princ " Суммарный периметр полилиний - ")(princ sum_pline)(princ "\n")
(princ " Сумма площадей \"замкнутых\" полилиний - ")(princ asum_pline)(princ "\n")
(princ)
)
)
)




(princ "\n Загружена утилита Lsum,\n")
(princ " вычисляющая сумму длин линий и суммарный периметр полилиний,\n")
(princ " для \"замкнутых\" полилиний вычисляется сумма площадей.\n")
(princ " Для работы с утилитой введите в командной строке Lsum.\n")
(textscr)
(princ)
__________________
"Безвыходных ситуаций не бывает" барон Мюнхаузен

Последний раз редактировалось Tyhig, 19.12.2022 в 17:14.
Tyhig вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Нужен LISP для суммы длин отрезков линни

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

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