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

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

Любой язык. Создание программы по автоматизации подсчета и нанесения площадей на чертеж

Ответ
Поиск в этой теме
Непрочитано 19.03.2019, 10:18 #1
Любой язык. Создание программы по автоматизации подсчета и нанесения площадей на чертеж
VolSilm
 
Регистрация: 24.04.2013
Сообщений: 17

Всем здравствуйте!

Задал вопрос в соответствующей теме (см. ниже) по написанию программы. Но, видимо, на лиспе никому не интересна данная задача.

Поэтому оставляю запрос на написание здесь, язык написания не важен. ПО, где планируется использовать (если это важно) - AutoCad 2012, 2014 и 2018, Windows.

Давно использую замечательную программу от VVA из поста №3.

Под свои чуть расширенные нужды и в меру своих кривых рук вписал в одну строчку кода с объектами штриховку, чтобы пога понимала этот объект, и в другие намертво зашил коэффициент, чтобы сразу в "м2" выдавала результат (при условии, что размерность чертежа "мм").


Код:
[Выделить все]
 
;  Команда: PTLB
;  Эта команда позволяет вставить в указанную точку рисунка или указанную ячейку таблицы
;  текст с полем (FIELD), содержащее значение площади или длины построенного или выбранного контура.
;  Точность округления и масштабный коэффициент настраиваются через опцию Установки
;  Так как это поле связано с конкретным объектом, то при изменении
;  объекта поле пересчитывается (необходимо обновление поля)
;  Код можно сохранить в файле ptlb.lsp
;  Возможный макрос для кнопки или пункта меню:
;  ^C^C(if (not C:PTLB) (load "ptlb"));PTLB;
;; Вариант макроса для задания м2
;; ^C^C(if (not C:PTLB) (load "ptlb"));PTLB;_L;_S;1;0.001;2;3;5;;м2;
;;Где
;; _L - считать длинну (_A - площадь)
;; _S - установки
;; 1 - линейный масштабный коэффициент
;; 0.001 — площадной масштабный коэффициент
;; 2 — точность представления чисел
;; 3 - Кратность округления (0-Нет)
;; 5 — высота текста
;; префикса нет
;; м2 - суффикс

(defun C:PTLB1 ( / en cmdname fld txt fc tblset tblobj row col pt
                 whatAcadVer tstyle what *error* layer-status-save
               layer-status-restore
               )
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008
(defun whatAcadVer ( / Aver)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.2) 2012)  
((= Aver 18.1) 2011)  
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= Aver 17.1) 2008)
((= Aver 17.0) 2007)
((= Aver 16.2) 2006)    
((= Aver 16.1) 2005)
((= Aver 16.0) 2004)
((= Aver 15.06) 2002)
(t 2013)
)
)
  (defun _round (num prec)
  (cond ((zerop prec) num)
        (t
         (* prec
            (if (minusp num)
              (fix (- (/ num prec) 0.5))
              (fix (+ (/ num prec) 0.5))
              )
            )
         )
        )
)
  (defun *error* (msg)(layer-status-restore)
    (princ msg)(princ))
  (defun layer-status-save ()
    (setq *MIP_LAYER_LST* nil)
    (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) 
      (setq *MIP_LAYER_LST* (cons (list item 
                                  (cons "lock" (vla-get-lock item)) 
                                  ) ;_ end of cons 
                            *MIP_LAYER_LST* 
                            ) ;_ end of cons 
            ) ;_ end of setq 
      (vla-put-lock item :vlax-false)
      ) ;_ end of vlax-for
      
    );_ end of defun
(defun layer-status-restore () 
    (foreach item *MIP_LAYER_LST*
      (if (not (vlax-erased-p (car item))) 
        (vl-catch-all-apply 
          '(lambda () 
             (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
             ) ;_ end of lambda 
          ) ;_ end of vl-catch-all-apply 
        ) ;_ end of if 
      ) ;_ end of foreach
    (setq *MIP_LAYER_LST* nil)
    ) ;_ end of defun 
  (vl-load-com)
  (or *SCALEL* (setq *SCALEL* 1))
  (or *SCALEA* (setq *SCALEA* 1))
  (or *PREC* (setq *PREC* 2))
  (or *OKR* (setq *OKR* 0))
  (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
  (or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
  (setq *SUFF* (vl-princ-to-string *SUFF*))
  (setq *PREF* (vl-princ-to-string *PREF*))
  (and
    (or ;_ > Проверяем версию
      (> (whatAcadVer) 2005)
      (alert "\nНужен Автокад версии 2006 и выше")
      ) ;_ < Проверяем версию
    (or (initget "Length Area Длина Площадь _Length Area Length Area") t)
    (if (null (setq what (getkword "\nЧто будем считать [Длина/Площадь] <Длина> :")))
      (setq what "Length") t)
      (princ "\nТекущий масштаб: линейный = ")(princ *SCALEL*)(princ " площадной = ")(princ *SCALEA*)
      (princ " Точность = ")(princ *PREC*)
      (princ " Кратность округления =")(princ (if (zerop *OKR*) "нет" *OKR*))
      (princ " Высота текста = ")(princ *TEXTSIZE*)
      (princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*)
    (or
      (initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
      t
      )
    (or ;_ > Запрашиваем что рисовать + опции
    (while (= (setq cmdname (getkword (strcat (if (= what "Area") "\n<Площадь> " "\n<Длина> ")
           "Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: ")))
              "Setting")
      (princ "\nНовый линейный масштабный коэффициент <")(princ *SCALEL*)(princ "> : ")
      (initget 6)
      (if (setq en (getdist))(setq *SCALEL* en))
      (princ "\nНовый площадной масштабный коэффициент <")(princ *SCALEA*)(princ "> : ")
      (initget 6)
      (if (setq en (getdist))(setq *SCALEA* en))
      (princ "\nТочность представления чисел <")(princ *PREC*)(princ "> : ")
      (initget 4)
      (if (setq en (getint))(setq *PREC* en))
      (princ "Кратность округления (0-Нет) <")(princ (if (zerop *OKR*) "нет" *OKR*))(princ "> : ")
      (initget 4)
      (if (setq en (getreal))(setq *OKR* en))
      (princ "\nВысота текста <")(princ *TEXTSIZE*)(princ "> : ")
      (initget 6)
      (if (setq en (getdist))(setq *TEXTSIZE* en))
      (princ "\nПрефикс (пробел - очистить) <")(princ *PREF*)(princ "> : ")
      (setq en (getstring t))(if (= en "")(setq en *PREF*))
      (if (= en " ")(setq en ""))
      (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
      (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *PREF* en)
      (princ "\nСуффикс (пробел - очистить) <")(princ *SUFF*)(princ "> : ")
      (setq en (getstring t))(if (= en "")(setq en *SUFF*))
      (if (= en " ")(setq en ""))
      (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
      (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
      (initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
      )
    t
    ) ;_ < Запрашиваем что рисовать + опции
   (or (layer-status-save) t)
  (cond
    ((= cmdname "Polyline")(setvar "CMDECHO" 1)(command "_.PLINE")
     (while (> (getvar "CMDACTIVE") 0)(command pause))
     (setq en (entlast))
     )
    ((or (null cmdname)(= cmdname "sElect"))
         (princ "\nВыберите полилинию, круг, сплайн, эллипс или дугу или штриховку")
         (and
           (setq tblset (ssget "_:S:E" (if (= what "Area") '((0 . "*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE,HATCH"))
                                                           '((0 . "LINE,*POLYLINE,ARC,CIRCLE")))
                                         ))
           (setq en (ssname tblset 0))
           )
     )
    (t nil)
    )
  ;_ Формируем поле
  (cond
    ((= what "Area")
     (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
             (vl-princ-to-string(Get-ObjectID-x86-x64 (vlax-ename->vla-object en)))
                ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr2%ds44%ct8[1e-6]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    ((and (= what "Length")
          (= (cdr(assoc 0 (entget en))) "CIRCLE")
          )
     (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (Get-ObjectID-x86-x64 (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Circumference \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr2%ds44%ct8[1e-3]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    ((and (= what "Length")
          (= (cdr(assoc 0 (entget en))) "ARC")
          )
     (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (Get-ObjectID-x86-x64 (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).ArcLength \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr2%ds44%ct8[1e-3]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    ((and (= what "Length")
          (vlax-property-available-p (vlax-ename->vla-object en) "Length")
          )
     (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (Get-ObjectID-x86-x64 (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Length \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr2%ds44%ct8[1e-3]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    (t (setq fld "Неизвестное свойство"))
    )
;;;Округляем
   (if (not (zerop *OKR*))
     (setq fld
            (strcat
              "%<\\AcExpr ((Trunc("
              (substr fld 1 (1-(vl-string-search "\\f" fld)))
              ">%"
              " / "
              (vl-prin1-to-string *OKR*)
              " + 0.5"
              "))*"
              (vl-prin1-to-string *OKR*)
              ")"
              (substr fld (vl-string-search "\\f" fld))
              ;;">%"
              )
           )
     t
     )
(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 fld)
   (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) 0 fld)
   ) ;_ 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 fld) 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 fld)
      )
    )
  )
  (layer-status-restore)
  (princ)
  )
(princ "\nКоманда PTLB. Версия от 20.04.2011 http://forum.dwg.ru/showpost.php?p=183237&postcount=3")
(princ)

;;--------------------------------------------------------
;; Функция получает строковое представление ObjectID
;; вне зависимости от того AutoCAD x86 или x64
;; Источник: https://discussion.autodesk.com/forums/message.jspa?messageID=6172961
;; http://forum.dwg.ru/showthread.php?t=51822
;;--------------------------------------------------------
(defun Get-ObjectID-x86-x64 (obj / util)
  (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
  (if (= (type obj) 'VLA-OBJECT)
     (if (> (vl-string-search "x64" (getvar "platform")) 0)
       (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
       (rtos (vla-get-objectid obj) 2 0)
     )
  )
)
(princ "\nКоманда PTLB. Версия от 19.03.2012 http://forum.dwg.ru/showpost.php?p=183237&postcount=3")
(princ)



На этом мои способности к программированию закончились, а вот потребность в оптимизации рутины осталась.

В работе постоянно требуется вычислять кучу площадей полилиний или штриховок, с внесением их значений на чертеж. Значения нужно вносить как просто внутри контуров объектов, так и в таблицу. Поэтому крайне нужна программа, которая заменит бесчисленное кликанье мышкой на пару изящных движений. Т.е. она будет делать то же, что и PTLB от VVA, но автоматически для группы объектов.

Всего хотелось бы увидеть 2 функции (но даже одна из них уже будет бесценным подарком по сохранению трудодней):
  1. Есть группа полилиниий (штриховок). После вызова команды и выбора этой группы объектов, программа автоматически создает внутри этих объектов тексты с полями, в которых выведена площадь объекта (можно и длину, на выбор. МОжет, кому пригодится).
  2. Для той же группы объектов вывести знаения площадей в таблицу на чертеже. Например, брать значения площадей программа будет вдоль полилинии, которая пересекает искомые объекты, а выводить в таблицу начиная с указанной ячейки в столбик вниз по ячейкам.

Буду премного благодарен за помощь в этом направлении.
Просмотров: 3942
 
Непрочитано 19.03.2019, 10:41
#2
trir


 
Регистрация: 18.12.2010
Сообщений: 3,526


Для этого есть штатные инструменты в AutoCAD Map 3D
trir на форуме  
 
Автор темы   Непрочитано 19.03.2019, 11:17
#3
VolSilm


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


Цитата:
Сообщение от trir Посмотреть сообщение
Для этого есть штатные инструменты в AutoCAD Map 3D
Я, конечно, поверхностно ознакомился с новой политикой AutoDesk по специализированным версиям, но главная проблема - нет универсальности для старых/всех версий.

Любопытства ради - название инструмента в Map 3d не подскажете? Почитаю описание. Навскидку в гугле не нашел ничего про такой функционал
VolSilm вне форума  
 
Непрочитано 19.03.2019, 11:33
1 | #4
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 7,210


Цитата:
Сообщение от VolSilm Посмотреть сообщение
Всего хотелось бы увидеть 2 функции (но даже одна из них уже будет бесценным подарком по сохранению трудодней):
Цитата:
Сообщение от VolSilm Посмотреть сообщение
На этом мои способности к программированию закончились, а вот потребность в оптимизации рутины осталась.
Так обратитесь в раздел исполнителей - там и на лиспе напишут, если о цене сговоритесь...
Сергей812 вне форума  
 
Автор темы   Непрочитано 19.03.2019, 11:47
#5
VolSilm


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


Цитата:
Сообщение от Сергей812 Посмотреть сообщение
Так обратитесь в раздел исполнителей - там и на лиспе напишут, если о цене сговоритесь...
Сергей, спасибо за наводку именно на dwg.ru - в итоге планировал так и сделать, только на стороннем ресурсе (как-то узко мыслил, что тут только общаются, а заказы не заказывают) =)

Offtop: И да, сладкое слово халява как отражение надежды, что это программа будет нужна кому-то кроме меня
VolSilm вне форума  
 
Непрочитано 19.03.2019, 11:52
1 | #6
trir


 
Регистрация: 18.12.2010
Сообщений: 3,526


это создание аннотаций, там естри три варианта - например
trir на форуме  
 
Непрочитано 20.03.2019, 17:32
1 | #7
koMon


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


Цитата:
Сообщение от VolSilm Посмотреть сообщение
1. Есть группа полилиниий (штриховок). После вызова команды и ...
в качестве рыбы
Код:
[Выделить все]
 
;************
(vl-load-com)
;************

(defun c:PLH_Area ()
	(setq modelSpace_object (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
		text_size 5.0
		pickset_selected (ssget '((-4 . "<or") (0 . "LWPOLYLINE") (0 . "HATCH") (-4 . "or>")))
	)
	(while (and
			    (not (null pickset_selected))
			    (not (zerop (sslength pickset_selected)))
		   )
		   		(setq current_object (vlax-ename->vla-object (setq current_entity (ssname pickset_selected 0))))
				(if (and
						(= "AcDbPolyline" (vla-get-objectname current_object))
						(= :vlax-false (vla-get-closed current_object))
					)
						(setq pickset_selected (ssdel current_entity pickset_selected))
						(progn
		   			  			(setq pickset_selected (ssdel current_entity pickset_selected)
		   			  				  area_field_string (strcat
		   			  											"%<\\AcObjProp.16.2 Object(%<\\_ObjId "
		   														(itoa (vla-get-objectid current_object))
		   														">%).Area"
		   														" \\f \"%lu2%ds44%ct8[1e-6]\""
		   														">%"
		   						   	       				)
					  				  vlax_executed (vla-getboundingbox current_object 'llc 'urc)
	      			  				  	  current_object_center_X (+ (car (vlax-safearray->list llc)) (/ (- (car (vlax-safearray->list urc)) (car (vlax-safearray->list llc))) 2.0))
		  			  				  current_object_center_Y (+ (cadr (vlax-safearray->list llc)) (/ (- (cadr (vlax-safearray->list urc)) (cadr (vlax-safearray->list llc))) 2.0))
					  				  text_added (vla-AddText modelspace_object area_field_string (vlax-3d-point (list current_object_center_X current_object_center_Y)) text_size)
								)
								(vla-put-alignment text_added 10)
								(vla-put-textalignmentpoint text_added (vlax-3d-point (list current_object_center_X current_object_center_Y)))
						)
				)
	)
	(princ)
)
koMon вне форума  
 
Автор темы   Непрочитано 20.03.2019, 17:46
#8
VolSilm


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


----- добавлено через ~3 мин. -----
Цитата:
Сообщение от koMon Посмотреть сообщение
в качестве рыбы



Код:
[Выделить все]
 
;************
(vl-load-com)
;************

(defun c:PLH_Area ()
	(setq modelSpace_object (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
		text_size 5.0
		pickset_selected (ssget '((-4 . "<or") (0 . "LWPOLYLINE") (0 . "HATCH") (-4 . "or>")))
	)
	(while (and
			    (not (null pickset_selected))
			    (not (zerop (sslength pickset_selected)))
		   )
		   		(setq current_object (vlax-ename->vla-object (setq current_entity (ssname pickset_selected 0))))
				(if (and
						(= "AcDbPolyline" (vla-get-objectname current_object))
						(= :vlax-false (vla-get-closed current_object))
					)
						(setq pickset_selected (ssdel current_entity pickset_selected))
						(progn
		   			  			(setq pickset_selected (ssdel current_entity pickset_selected)
		   			  				  area_field_string (strcat
		   			  											"%<\\AcObjProp.16.2 Object(%<\\_ObjId "
		   														(itoa (vla-get-objectid current_object))
		   														">%).Area"
		   														" \\f \"%lu2%ds44%ct8[1e-6]\""
		   														">%"
		   						   	       				)
					  				  vlax_executed (vla-getboundingbox current_object 'llc 'urc)
	      			  				  	  current_object_center_X (+ (car (vlax-safearray->list llc)) (/ (- (car (vlax-safearray->list urc)) (car (vlax-safearray->list llc))) 2.0))
		  			  				  current_object_center_Y (+ (cadr (vlax-safearray->list llc)) (/ (- (cadr (vlax-safearray->list urc)) (cadr (vlax-safearray->list llc))) 2.0))
					  				  text_added (vla-AddText modelspace_object area_field_string (vlax-3d-point (list current_object_center_X current_object_center_Y)) text_size)
								)
								(vla-put-alignment text_added 10)
								(vla-put-textalignmentpoint text_added (vlax-3d-point (list current_object_center_X current_object_center_Y)))
						)
				)
	)
	(princ)
)



"Он живой!" (с)

Код работает, тестил на AutoCad 2018. И штриховки, и полилинии считает, текст с полями добавляет - класс!

Задача 1 решена
VolSilm вне форума  
 
Непрочитано 26.03.2019, 13:01
#9
tsetse

Инженер-конструктор
 
Регистрация: 25.12.2015
Москва
Сообщений: 54


С таблицей
Код:
[Выделить все]
  
;************
(vl-load-com)
;************

(defun c:PLH_Area ()
	(setq modelSpace_object (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
		text_size 5.0
		pickset_selected (ssget '((-4 . "<or") (0 . "LWPOLYLINE") (0 . "HATCH") (-4 . "or>")))
	)
	(setq eee (sslength pickset_selected))
	(setq row 1)
	(setq table nil)
	(setq table (vla-AddTable modelSpace_object (vlax-3D-point (getpoint "\nТочка левого верхнего угла таблицы: ")) (+ 2 eee) 2 5 50))
	(vla-SetText table 0 0 "ПЛОЩАДИ" )
	(vla-SetText table 1 0 "Номер" )
	(vla-SetText table 1 1 "ПЛОЩАДЬ" )
	(while (and
			    (not (null pickset_selected))
			    (not (zerop (sslength pickset_selected)))
		   )
		   		(setq current_object (vlax-ename->vla-object (setq current_entity (ssname pickset_selected 0))))
				(if (and
						(= "AcDbPolyline" (vla-get-objectname current_object))
						(= :vlax-false (vla-get-closed current_object))
					)
						(setq pickset_selected (ssdel current_entity pickset_selected))
						(progn
		   			  			(setq pickset_selected (ssdel current_entity pickset_selected)
		   			  				  area_field_string (strcat
		   			  											"%<\\AcObjProp.16.2 Object(%<\\_ObjId "
		   														(itoa (vla-get-objectid current_object))
		   														">%).Area"
		   														" \\f \"%lu2%ds44%ct8[1e-6]\""
		   														">%"
		   						   	       				)
					  				  vlax_executed (vla-getboundingbox current_object 'llc 'urc)
	      			  				  	  current_object_center_X (+ (car (vlax-safearray->list llc)) (/ (- (car (vlax-safearray->list urc)) (car (vlax-safearray->list llc))) 2.0))
		  			  				  current_object_center_Y (+ (cadr (vlax-safearray->list llc)) (/ (- (cadr (vlax-safearray->list urc)) (cadr (vlax-safearray->list llc))) 2.0))
					  				  text_added (vla-AddText modelspace_object area_field_string (vlax-3d-point (list current_object_center_X current_object_center_Y)) text_size)
								)
								(vla-put-alignment text_added 10)
								(vla-put-textalignmentpoint text_added (vlax-3d-point (list current_object_center_X current_object_center_Y)))
								(vla-SetText table (1+ row) 0 row)
								(vla-SetText table (1+ row) 1 area_field_string)
								(setq row (1+ row))


						)
				)
	)
	(princ)
)
tsetse вне форума  
 
Автор темы   Непрочитано 26.03.2019, 16:04
#10
VolSilm


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


Цитата:
Сообщение от tsetse Посмотреть сообщение
С таблицей
огромное спасибо!

доработал код под свои утилитарные нужды (формирование таблицы по форме экспликации помещений, с *почти* графами по ГОСТ; точность 2 знака после запятой; все элементы набраны таким образом, что при масштабе 1:100 они отображаются с высотой текста 2,5 мм).

Правда, потребует специфического табличного стиля с отступами и все такое (или доработать под свои нужды ширину/высоты столбцов/строк).



Код:
[Выделить все]
  
;************
(vl-load-com)
;************

(defun c:PLH_Area ()
	(setq modelSpace_object (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
		text_size 250.0
		pickset_selected (ssget '((-4 . "<or") (0 . "LWPOLYLINE") (0 . "HATCH") (-4 . "or>")))
	)
	(setq eee (sslength pickset_selected))
	(setq row 1)
	(setq table nil)

	(setq table (vla-AddTable modelSpace_object (vlax-3D-point (getpoint "\nТочка левого верхнего угла таблицы: ")) (+ 2 eee) 4 800 2000))	;формирование таблицы с количеством строк равным количеству выбранных объектов
                                                                                                                       
	(vla-SetText table 0 0 "Название таблицы" )	;содержимое "Шапки" таблицы (Название таблицы)

	(vla-setcolumnwidth table 0 1500)		;ширина 1-го столбца таблицы таблицы
	(vla-setcolumnwidth table 1 8000)		;ширина 2-го столбца таблицы
	(vla-setcolumnwidth table 2 2000)		;ширина 3-го столбца таблицы
	(vla-setcolumnwidth table 3 1000)		;ширина 4-го столбца таблицы

	(vla-setrowheight table 1 2000)			;высота строки заголовков таблицы

	(vla-SetText table 1 0 "Номер помещения" )	;заголовок 1-го столбца таблицы
	(vla-SetText table 1 1 "Наименование" )		;заголовок 2-го столбца таблицы
	(vla-SetText table 1 2 "Площадь, кв. м" )	;заголовок 3-го столбца таблицы
	(vla-SetText table 1 3 "Кат. пом." )		;заголовок 4-го столбца таблицы

	(while (and
			    (not (null pickset_selected))
			    (not (zerop (sslength pickset_selected)))
		   )
		   		(setq current_object (vlax-ename->vla-object (setq current_entity (ssname pickset_selected 0))))
				(if (and
						(= "AcDbPolyline" (vla-get-objectname current_object))
						(= :vlax-false (vla-get-closed current_object))
					)
						(setq pickset_selected (ssdel current_entity pickset_selected))
						(progn
		   			  			(setq pickset_selected (ssdel current_entity pickset_selected)
		   			  				  area_field_string (strcat
		   			  											"%<\\AcObjProp.16.2 Object(%<\\_ObjId "
		   														(itoa (vla-get-objectid current_object))
		   														">%).Area"
		   														" \\f \"%lu2%ds44%pr2%ct8[1e-6]\""
		   														">%"
		   						   	       				)
					  				  vlax_executed (vla-getboundingbox current_object 'llc 'urc)
	      			  				  	  current_object_center_X (+ (car (vlax-safearray->list llc)) (/ (- (car (vlax-safearray->list urc)) (car (vlax-safearray->list llc))) 2.0))
		  			  				  current_object_center_Y (+ (cadr (vlax-safearray->list llc)) (/ (- (cadr (vlax-safearray->list urc)) (cadr (vlax-safearray->list llc))) 2.0))
					  				  text_added (vla-AddText modelspace_object area_field_string (vlax-3d-point (list current_object_center_X current_object_center_Y)) text_size)
								)
								(vla-put-alignment text_added 10)
								(vla-put-textalignmentpoint text_added (vlax-3d-point (list current_object_center_X current_object_center_Y)))
								(vla-SetText table (1+ row) 0 row)
								(vla-SetText table (1+ row) 2 area_field_string)
								(setq row (1+ row))


						)
				)
	)
	(princ)
)


А не подскажет кто-нибудь, как сказать автокаду, чтобы он брал объекты в порядке пересечения полилинии? А то сейчас приходится тыкать каждый объект в том порядке, в котором хочешь увидеть их в таблице

Наподобие нумератора , он нумерует вдоль полилинии.

Последний раз редактировалось VolSilm, 26.03.2019 в 23:38.
VolSilm вне форума  
 
Непрочитано 27.03.2019, 09:03
1 | #11
koMon


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


Цитата:
Сообщение от VolSilm Посмотреть сообщение
А не подскажет кто-нибудь, как сказать автокаду, чтобы он брал объекты в порядке пересечения полилинии?
как-то так
Код:
[Выделить все]
 
;************
(vl-load-com)
;************

(defun c:PLH_Area ()
    (setq modelSpace_object (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
        text_size 5.0
		getting_crossing_pline t
	)

	(while getting_crossing_pline
		(while (null (setq crossing_pline_selected_data (vl-catch-all-apply 'entsel (list "\nВыберите секущую полилинию: ")))))
		(cond
			(
				(= 'vl-catch-all-apply-error (type crossing_pline_selected_data))
					(setq pickset_selected nil)
			)
			(
				t
					(setq crossing_pline_object (vlax-ename->vla-object (setq crossing_pline_entity (car crossing_pline_selected_data)))
						  fence_vertices_raw_list (vlax-get crossing_pline_object 'coordinates)
						  fence_vertices_list '()
						  lisp_executed	(while fence_vertices_raw_list
											(setq fence_vertices_list (append fence_vertices_list (list (list (car fence_vertices_raw_list) (cadr fence_vertices_raw_list))))
												  fence_vertices_raw_list (cddr fence_vertices_raw_list)
											)
										)
						  pickset_selected (ssdel crossing_pline_entity (ssget "_f" fence_vertices_list '((-4 . "<OR") (0 . "LWPOLYLINE") (0 . "HATCH") (-4 . "OR>"))))
					)
			)
		)
		(cond
			(
				(null pickset_selected)
					(setq getting_crossing_pline nil)
			)
			(
				(not (zerop (sslength pickset_selected)))
					(setq getting_crossing_pline nil)
			)
			(
				t
					(alert "Не найдено пересекаемых примитивов!")
			)
		)
	)

    (setq eee (sslength pickset_selected))
    (setq row 1)
    (setq table nil)
    (setq table (vla-AddTable modelSpace_object (vlax-3D-point (getpoint "\nТочка левого верхнего угла таблицы: ")) (+ 2 eee) 2 5 50))
    (vla-SetText table 0 0 "ПЛОЩАДИ" )
    (vla-SetText table 1 0 "Номер" )
    (vla-SetText table 1 1 "ПЛОЩАДЬ" )
    (while (and
                (not (null pickset_selected))
                (not (zerop (sslength pickset_selected)))
           )
                (setq current_object (vlax-ename->vla-object (setq current_entity (ssname pickset_selected 0))))
                (if (and
                        (= "AcDbPolyline" (vla-get-objectname current_object))
                        (= :vlax-false (vla-get-closed current_object))
                    )
                        (setq pickset_selected (ssdel current_entity pickset_selected))
                        (progn
                                (setq pickset_selected (ssdel current_entity pickset_selected)
                                      area_field_string (strcat
                                                                "%<\\AcObjProp.16.2 Object(%<\\_ObjId "
                                                                (itoa (vla-get-objectid current_object))
                                                                ">%).Area"
                                                                " \\f \"%lu2%ds44%ct8[1e-6]\""
                                                                ">%"
                                                        )
                                      vlax_executed (vla-getboundingbox current_object 'llc 'urc)
                                      current_object_center_X (+ (car (vlax-safearray->list llc)) (/ (- (car (vlax-safearray->list urc)) (car (vlax-safearray->list llc))) 2.0))
                                      current_object_center_Y (+ (cadr (vlax-safearray->list llc)) (/ (- (cadr (vlax-safearray->list urc)) (cadr (vlax-safearray->list llc))) 2.0))
                                      text_added (vla-AddText modelspace_object area_field_string (vlax-3d-point (list current_object_center_X current_object_center_Y)) text_size)
                                )
                                (vla-put-alignment text_added 10)
                                (vla-put-textalignmentpoint text_added (vlax-3d-point (list current_object_center_X current_object_center_Y)))
                                (vla-SetText table (1+ row) 0 row)
                                (vla-SetText table (1+ row) 1 area_field_string)
                                (setq row (1+ row))
                        )
                )
    )
    (princ)
)

Последний раз редактировалось koMon, 27.03.2019 в 09:12.
koMon вне форума  
 
Непрочитано 27.03.2019, 11:19
1 | #12
gumel

ООО "Ниф-Ниф"
 
Регистрация: 20.04.2011
Сообщений: 214


У Lee Mac'а есть штука которая расставляет площади через зависимые поля:



Квадратные метры можно легко сварганить, поправив код:

Код:
[Выделить все]
 (setq fmt "%lu2%pr2%ct8[1e-006]%ps[, м\\U+00B2]") ;; квадратные миллиметры в квадаратные метры (mm2->m2) с точностью 2 знака после запятой
gumel вне форума  
 
Автор темы   Непрочитано 27.06.2019, 14:07 Доработанная программа
#13
VolSilm


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


Всем привет!

Дополнил программу с позволения уважаемых tsetse и KoMon. Исполнительное ядро - их. Я только оформил.

Теперь программа раскидывает по заранее задаваемым слоям создаваемые объекты текстов и экспликации, а также вставляет рядом с текстами площадей блоки номеров помещений с содержимым, совпадающим с графой "Номер помещения" в создаваемой экспликации.
При необходимости в начале программы вы можете изменить названия слоев, по которым раскидывать, а также вставляемый блок.
Слои и блок должны существовать на чертеже.

Помимо этого экспликация и тексты с площадями формируются в соответствии с заранее задаваемым масштабом элементов.
Заполняется шапка и заголовки экспликации, в конце экспликации происходит суммирование значений площадей в строке "Итого"


Код:
[Выделить все]
   
  
;************
(vl-load-com)
;************

(defun c:PLH_AREA ( / 	modelSpace_object
                     current_layer scale_factor text_size_fact
			                osmode_old attdia_old attreq_old
		  	                bl_name
		  	                getting_crossing_pline pickset_selected
			                crossing_pline_object crossing_pline_selected_data
			                fence_vertices_raw_list fence_vertices_list
			                lisp_executed
		  	               eee row ITOGO table
		  	               vlax_executed current_object_center_X current_object_center_Y
		  	               text_added 

		           )
  
	(setq modelSpace_object (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))

		;;;;;;;;;;;;;;;;;;;; Назначаем и запоминаем слои объектов ;;;;;;;;;;;;;;;;;;;;;;;
	      
	      current_layer (getvar "CLAYER")					;; запоминаем текущий слой пользователя
	      layer_of_text "05 ПЛОЩАДЬ_ТЕКСТ"					;; назначаем слой размещения текста
	      layer_of_explication "06 УСЛОВНЫЕ ОБОЗНАЧЕНИЯ_ЭКСПЛИКАЦИЯ"	;; назначаем слой размещения экспликации
	      
	      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	      
		scale_factor 100.0	;; введите масштаб текстовых, размерных, табличных элементов чертежа
	      
	      	text_size 2.5		;; введите размер текста
	      
	      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	      
	      	text_size_fact (* scale_factor text_size)	;; фактический размер текста с учетом масштабного фактора

	      ;;;;;;;;;;;;;;;;;; Имя блока, который будет вставляться вместе с текстом с величиной площади;;;;;;;;;;;;;;;;;;;;;;;;;;;
	bl_name "ОБОЗНАЧЕНИЯ_НОМЕР ПОМЕЩЕНИЯ"
	      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	osmode_old (getvar 'OSMODE) ;; запоминаем текущее значение объектных привязок
	attdia_old (getvar 'ATTDIA) ;; запоминаем текущее значение переменной ATTDIA
	      
;;	attreq_old (getvar 'ATTREQ) ;; запоминаем текущее значение переменной ATTREQ
	      
	getting_crossing_pline t
	)
  
	;;; Формирование набора объектов, пересекаемого наводящей полилинией
  (while getting_crossing_pline
		(while (null (setq crossing_pline_selected_data (vl-catch-all-apply 'entsel (list "\nВыберите секущую полилинию: ")))))
		(cond
			(
				(= 'vl-catch-all-apply-error (type crossing_pline_selected_data))
					(setq pickset_selected nil)
			)
			(
				t
					(setq crossing_pline_object (vlax-ename->vla-object (setq crossing_pline_entity (car crossing_pline_selected_data)))
						  fence_vertices_raw_list (vlax-get crossing_pline_object 'coordinates)
						  fence_vertices_list '()
						  lisp_executed	(while fence_vertices_raw_list
											(setq fence_vertices_list (append fence_vertices_list (list (list (car fence_vertices_raw_list) (cadr fence_vertices_raw_list))))
												  fence_vertices_raw_list (cddr fence_vertices_raw_list)
											)
										)
						  pickset_selected (ssdel crossing_pline_entity (ssget "_f" fence_vertices_list '((-4 . "<OR") (0 . "LWPOLYLINE") (0 . "HATCH") (-4 . "OR>"))))
					)
			)
		)
		(cond
			(
				(null pickset_selected)
					(setq getting_crossing_pline nil)
			)
			(
				(not (zerop (sslength pickset_selected)))
					(setq getting_crossing_pline nil)
			)
			(
				t
					(alert "Не найдено пересекаемых примитивов!")
			)
		)
	) ;; окончание формирования набора объектов

	(setvar 'ATTDIA 0)						;; выставляем ATTDIA  в 0
  
;;  	(setvar 'ATTREQ 0)						;; выставляем ATTREQ  в 0
  
  	(setvar "CLAYER" "06 УСЛОВНЫЕ ОБОЗНАЧЕНИЯ_НОМЕР ПОМЕЩЕНИЯ")	;; выставление текущим слоя для размещения блоков номеров помещений
  	(setvar 'OSMODE 0)						;; отключение объектной привязки
  
	(setq eee (sslength pickset_selected))				;; запоминаем количество объектов, выбранных секущей полилинией
  
	(setq row 1)
	(setq ITOGO 0.00)
	(setq table nil)
  
  ;;; формирование таблицы с количеством строк равным количеству выбранных объектов и дополнительными 3-мя строками (шапка таблицы, строка зазголовков и строка ИТОГО), а также последующая настройка размеров и заполнение заголовков таблицы
  
	(setq table (vla-AddTable modelSpace_object (vlax-3D-point (getpoint "\nТочка левого верхнего угла таблицы: ")) (+ 3 eee) 4 (* scale_factor 8) (* scale_factor 20))) ;; создание таблицы
  	(vla-put-Layer table layer_of_explication) ;; назначение слоя таблицы
                                                                                                                       
	(vla-SetText table 0 0 "Название таблицы (шапка)" )	;; содержимое "Шапки" таблицы (Название таблицы) с использованием полей, забираемых из Свойств Чертежа

	(vla-setcolumnwidth table 0 (* scale_factor 15))		;; ширина 1-го столбца таблицы
	(vla-setcolumnwidth table 1 (* scale_factor 80))		;; ширина 2-го столбца таблицы
	(vla-setcolumnwidth table 2 (* scale_factor 20))		;; ширина 3-го столбца таблицы
	(vla-setcolumnwidth table 3 (* scale_factor 10))		;; ширина 4-го столбца таблицы

	(vla-setrowheight table 1 (* scale_factor 20))			;; высота строки заголовков таблицы

	(vla-SetText table 1 0 "Номер помещения" )			;; заголовок 1-го столбца таблицы
	(vla-SetText table 1 1 "Наименование" )				;; заголовок 2-го столбца таблицы
	(vla-SetText table 1 2 "Площадь, м\\U+00B2" )			;; заголовок 3-го столбца таблицы
	(vla-SetText table 1 3 "Кат. пом." )				;; заголовок 4-го столбца таблицы

	;; окончание формирования и настройки таблицы

  ;;;;;;;;;;;;;;;;;; Размещение текстов с площадями внутри контуров, размещение блоков с номерами помещение, заполнение экспликации значениями площадей;;;;;;;;;;;;;;;;;;;;;;;;;
	(while (and
			    (not (null pickset_selected))
			    (not (zerop (sslength pickset_selected)))
		   )							;; окончание задания условия цикла
	  
		   		(setq current_object (vlax-ename->vla-object (setq current_entity (ssname pickset_selected 0))))
	  
				(if (and
						(= "AcDbPolyline" (vla-get-objectname current_object))
						(= :vlax-false (vla-get-closed current_object))
					)
						(setq pickset_selected (ssdel current_entity pickset_selected))
						(progn
		   			  			(setq pickset_selected (ssdel current_entity pickset_selected)
		   			  				  area_field_string (strcat
		   			  											"%<\\AcObjProp.16.2 Object(%<\\_ObjId "
		   														(itoa (vla-get-objectid current_object))
		   														">%).Area"
		   														" \\f \"%lu2%ds44%pr2%ct8[1e-6]\""
		   														">%"
		   						   	       				)
					  				  vlax_executed (vla-getboundingbox current_object 'llc 'urc)
	      			  				  	  current_object_center_X (+ (car (vlax-safearray->list llc)) (/ (- (car (vlax-safearray->list urc)) (car (vlax-safearray->list llc))) 2.0))
		  			  				  current_object_center_Y (+ (cadr (vlax-safearray->list llc)) (/ (- (cadr (vlax-safearray->list urc)) (cadr (vlax-safearray->list llc))) 2.0))
					  				  text_added (vla-AddText modelspace_object area_field_string (vlax-3d-point (list current_object_center_X current_object_center_Y)) text_size_fact)	;;размещение текста внутри объекта чертежа
									
								)

						  		
						  		(command "_insert" bl_name (list current_object_center_X (+ current_object_center_Y (* text_size_fact 2)) 0.0) 1 1 0 row) ;;; вставка блока НОМЕРА ПОМЕЩЕНИЙ со значением ячейки № помещения из экспликации (таблицы)
					  		
									;;; настройка параметров текста  
								(vla-put-alignment text_added 10)	
								(vla-put-textalignmentpoint text_added (vlax-3d-point (list current_object_center_X current_object_center_Y)))
						  		(vla-put-Layer text_added layer_of_text)

						  			;;; заполнение таблицы
								(vla-SetText table (1+ row) 0 row)				;; выставление номера помещения в соответствующей ячейке таблицы
								(vla-SetText table (1+ row) 2 area_field_string)		;; выставление поля с величиной площади в соответствующей ячейке таблицы

								(vla-SetCellAlignment table (1+ row) 1 acMiddleLeft)		;; в исходном коде не было. Выставление выравнивания в столбце "Наименование"

								(setq row (1+ row))
								
						)
				) 		;; окончание условия if
	)   ;; окончание цикла while "Размещение текстов с площадями внутри контуров, размещение блоков с номерами помещение, заполнение экспликации значениями площадей"

	(vla-SetText table (1+ row) 1 "Итого") 				;; размещение надписи "Итого" в экспликации после наименований всех помещений
	(vla-SetCellAlignment table (1+ row) 1 acMiddleRight) 		;; выравнивание ячейки с "Итого" (середина справа)

  
 	;;; размещение суммы площадей в ячейке после последнего помещения
	(vla-SetText table (1+ row) 2 
					(strcat "=SUM(C3:C" (itoa (1+ row)) ")") 
	)	;; окончание размещения суммы площадей в ячейке после последнего помещения
  		
	(vla-SetCellDataType Table (1+ row) 2 acDouble acUnitArea) 			;; назначение типа данных "вещественный" для вышеназванной ячейки суммы площадей
	
	(vla-setDataFormat table (1+ row) 2 0 "%lu2%pr2%ds44%ct8[1e-6]") 		;; выставление нужного формата чисел ячейки для суммы площадей

  	(setvar 'ATTDIA attdia_old)	;; возврат значение ATTDIA к пользовательскому
  
;;  	(setvar 'ATTREQ attreq_old)	;; возврат значение ATTREQ к пользовательскому
  
  	(setvar "CLAYER" current_layer) ;; возврат значения текущего слоя к состоянию до того, как понадобилось разместить блок с номером помещения
	(setvar 'OSMODE osmode_old)	;; включение объектных привязок


  
	(princ)
)

Последний раз редактировалось VolSilm, 30.06.2019 в 18:20. Причина: Доработал программу до более приличного вида - ввел локальные переменные, раскидал по слоям создаваемые в процессе выполнения программы объекты
VolSilm вне форума  
 
Автор темы   Непрочитано 09.07.2019, 09:55
#14
VolSilm


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


Цитата:
Сообщение от gumel Посмотреть сообщение
У Lee Mac'а есть штука которая расставляет площади через зависимые поля:



Квадратные метры можно легко сварганить, поправив код:

Код:
[Выделить все]
 (setq fmt "%lu2%pr2%ct8[1e-006]%ps[, м\\U+00B2]") ;; квадратные миллиметры в квадаратные метры (mm2->m2) с точностью 2 знака после запятой
Нашел у того же Lee Mac доработанный вариант программы - там уже зашиты м2, а также добавлена возможность считать длины (как по отдлеьности, так и выдавать сумму набора).

http://www.lee-mac.com/lengthfield.html

Также прога умеет вставлять результат в ячейку таблицы
VolSilm вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Любой язык. Создание программы по автоматизации подсчета и нанесения площадей на чертеж

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Как перенести 2d чертеж из Inventor в AutoCAD любой версии gomerhack Прочее ПО от Autodesk 8 06.09.2014 15:21
Чем отличается монтажный чертеж от сборочного? (о норме ЕСКД 2.109) unoferito Машиностроение 10 17.02.2014 14:39
LISP для подсчета суммы длин линий Kostinok LISP 18 26.04.2013 14:56
Измеритель влажности (любой) нужен чертеж mr.MAIL Поиск литературы, чертежей, моделей и прочих материалов 2 19.08.2008 00:25
Как сделать правильный чертеж pk77 Разное 64 03.04.2007 16:36