[dew]

Ребята знаю что обязательно тут помогут, уже не раз выручали, у меня к вам очередная прозьба:
существует куча программок для простановке площадей на плане, но не одной не нашел для простановки объема.
может у кого есть, или может есть добрые люди , кто напишет не большой лисп ( чтоты работал как с полилинеей так и с отрезками, и стандартными 2Д фигурами)
Желательно чтобы когда счелкаю внутри контура нужного «помещения» 2Д фигуры , следовал запрос на ввод данных.
1-я строка - название помещения (ввожу с клавиатуры)
2-я строка - высота помещения (ввожу с клавиатуры)
3-я строка - объем помещения
Так же желательна небольшая меню с возможностью указания точности измерения (количество знаков после запятой, и маштаб измерения.

попробую изобразить образец :

топочная
-----------
Н=2.5м
V=45.21м3

Работаю а автокаде 2012 х64
Тест высотой 2.5 Standart
Маштаб измерения – «по стандарту» - 1:100 или (0,01)
Было бы идеально если за основу был бы взят данный ЛИСП «который рассчитывает площадь»

	(defun c:boundarea (/ area        util
	              point        mt
	              mt2          bound
	              bes-scale        bes-get-text
	              s1           scale
	              *acad_application*
	              *utility*        bes-put-vla-object-property
	              bes-getstring    bes-getpoint
	              bes-getinteger   space)
	 
	 
	  (vl-load-com)
	  (setq *acad_application* (vlax-get-acad-object)
	    *active_document* (vla-get-activedocument *acad_application*)
	    *utility* (vla-get-Utility *active_document*)
	    )
	   
	  (defun bes-getstring (str keywords / obj)
	    (vla-InitializeUserInput *utility* 128 keywords)
	    (if
	      (and
	    (not
	      (vl-catch-all-error-p
	        (setq obj
	           (vl-catch-all-apply
	             'vla-GetKeyWord
	             (list *utility* str)
	             )
	          )
	        )
	      )
	    (> (strlen obj) 0)
	    )
	      obj
	      )
	    )
	   
	  (defun bes-getpoint (str / obj )
	    (if
	      (not
	    (vl-catch-all-error-p
	      (setq obj
	         (vl-catch-all-apply
	           'vla-GetPoint
	           (list *utility* nil str)
	           )
	        )
	      )
	    )
	      obj
	      )
	    )
	 
	(defun bes-getinteger (str  / obj)
	  (vla-InitializeUserInput *utility*  4)
	  (if
	      (not
	    (vl-catch-all-error-p
	      (setq obj
	         (vl-catch-all-apply
	           'vla-GetInteger
	           (list *utility* str)
	           )
	        )
	      )
	    )
	    obj
	    )
	  )
	 
	  (defun bes-put-vla-object-property (obj property_name property)
	  (if
	    (not
	      (vl-catch-all-error-p
	    (vl-catch-all-apply
	      'vlax-put-property
	      (list obj property_name property)
	      )
	     
	    )
	      )
	    property
	    nil
	    )
	  )
	   
	  (defun bes-scale ( / s1 p1 p2 scale)
	    (if
	      (and
	    (princ (strcat "\nТекущий масштаб: " *bes_scale*))
	    (setq scale (bes-getstring "\nВведите масштаб вида 1:x или х:1, где х - число: " ""))
	    (setq s1 (vl-string-position  (ascii ":" ) scale))
	    (numberp (setq p1 (atoi (substr scale 1 (1+ s1)))))
	    (numberp (setq p2 (atoi (substr scale (+ 2 s1)))))
	    (not (minusp p1))
	    (not (minusp p2))
	    (/= 0 p1)
	    (/= 0 p2)
	    (or
	      (= p1 1)
	      (= p2 1)
	      )
	    )
	      (progn
	    (setq *bes_scale* (strcat (vl-princ-to-string p1) ":" (vl-princ-to-string p2)))
	    (princ (strcat "\nТекущий масштаб: " *bes_scale*))
	    (setq mt2 (bes-get-text))
	    )
	      (progn
	    (princ (strcat "\nТекущий масштаб: " *bes_scale*))
	    (setq mt2 (bes-get-text))
	    t
	    )
	      )
	    )
	 
	  (defun bes-get-text ( / scale mt2)
	    (setq mt2 (bes-getstring "\nВведите название помещения или [Масштаб/Точность]:" "Масштаб Точность"))
	    (if mt2
	      (progn
	    (cond
	      (
	       (equal mt2 "Масштаб")
	       (bes-scale)
	       )
	      (
	       (equal mt2 "Точность")
	       (princ (strcat "\nТекущая точность: " (itoa *bes-integer*)))
	       (setq *bes-integer* (bes-getinteger "\nВведите количество знаков после запятой: "))
	       (princ (strcat "\nТекущая точность: " (itoa *bes-integer*)))
	       (setq mt2 (bes-get-text))
	       )
	      )
	    mt2
	    )
	      )
	    )
	   
	  (if (not *bes_scale*)
	    (setq *bes_scale* "1:1")
	    )
	  (if (not *bes-integer*)
	    (setq *bes-integer* 1)
	    )
	  (if
	    (and
	      (setq point (bes-getpoint "\nУкажите точку внутри замкнутого контура:"))
	      (setq bound (bpoly (vlax-safearray->list (vlax-variant-value point))))
	      )
	    (if (setq mt2 (bes-get-text))
	      (progn
	    (setq area (/ (vla-get-Area (vlax-ename->vla-object bound)) 100))
	    (setq s1 (vl-string-position  (ascii ":" ) *bes_scale*))
	    (setq scale
	           (list
	         (atoi (substr *bes_scale* 1 (1+ s1)))
	         (atoi (substr *bes_scale* (+ 2 s1)))
	         )
	          )
	    (if (> (car scale)
	           (cadr scale)
	           )
	      (setq area (* area (expt (car scale) 2)))
	      (setq area (/ area (expt (cadr scale) 2)))
	      )
	    (setq area (rtos area 2 *bes-integer*))
	    (if
	      (= (vla-get-ActiveSpace *active_document*) 1)
	      (setq space (vla-get-ModelSpace *active_document*))
	      (setq space (vla-get-PaperSpace *active_document*))
	      )
	    (setq mt
	           (vla-AddMtext space point 5
	         (strcat "\\A1;{\\H1.0x;\\S" mt2 "/"
	             (vl-princ-to-string area) " м2;}"
	             )
	         )
	          )
	    (mapcar
	      (function
	        (lambda (a)
	          (bes-put-vla-object-property
	        mt
	        (car a)
	        (cadr a)
	        )
	          )
	        )
	      (list
	        '("AttachmentPoint" 5)
	        )
	      )
	    )
	      )
	    )  
	  (if
	    bound
	    (entdel bound)
	    )
	  (princ)
	  )

[dew]

И никто не поможет (:
Ну сегодня, пятница, кто еще не успел сделать доброе дело на этой недели - торопитесь

[kp+]

Сообщение от dew 1-я строка - название помещения (ввожу с клавиатуры) 2-я строка - высота помещения (ввожу с клавиатуры) 3-я строка - объем помещения Так же желательна небольшая меню с возможностью указания точности измерения (количество знаков после запятой, и маштаб измерения. попробую изобразить образец : топочная ----------- Н=2.5м V=45.21м3 Работаю а автокаде 2012 х64 Тест высотой 2.5 Standart Маштаб измерения – «по стандарту» - 1:100 или (0,01) Было бы идеально если за основу был бы взят данный ЛИСП «который рассчитывает площадь»

такое, без шуток, техническое задание надо размещать в ветке "поиск исполнителей".

[Олег (jr.)]

Попробуй, не проверял

Код:

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

;;-----------------------------------------------------------------------;;
(defun C:AVL(/ acsp adoc ar height ht mtx pl plobj pt room sc txth vol)
  (vl-load-com)
(defun *error* (msg)
      (vla-endundomark (vla-get-activedocument
              (vlax-get-acad-object))
	      )
    (cond ((or (not msg)
	       (member msg '("console break" "Function cancelled" "quit / exit abort"))
	       )
	   )
	  ((princ (strcat "\nError: " msg)))
	  )
(setvar "cmdecho" 1)
    (princ)
    )
 
;;------------------------------ main part -------------------------------;;
  
(setq adoc (vla-get-activedocument
              (vlax-get-acad-object))
      acsp (vla-get-block(vla-get-activelayout adoc))) 
  (vla-startundomark adoc )  
  (setvar "cmdecho" 0)

  (initget 6)
  (setq txth (getreal (strcat "\nEnter text height for label <" (rtos(getvar "dimtxt")) ">: ")))
  (cond ((/= txth 2.5)(setq txth 2.5)))
  
    (initget  "1 0.1 0.01 0.001")
  (setq sc (getreal "\nScale [1/0.1/0.01/0.001] < 0.01 > : "))
  (while (setq pt (getpoint "\nPick point inside (or press Enter to Exit): "))
    (setvar "clayer" "Defpoints")
    (command "-boundary" pt "")

    (setq pl (entlast))
    (setq room (getstring T "\nType room name: "))
    (setq height (strcat "H = " (rtos (setq ht (getreal  "\nType room height: ")) 2 2)))

    (setq plobj (vlax-ename->vla-object pl))
    (setq ar (vla-get-area plobj))
    (setq vol (rtos (* (expt sc 3)(* ht ar)) 2 2))
    (setvar "clayer" "0")			  ;<-- set text layer here
    (setq mtx (vlax-invoke
		acsp
		'addmtext
		pt
		0.0
		(strcat "\\A1;" room "\\P" height "\\P" vol " ì{\\H0.5x;\\S3;}")))
		
    (vlax-put mtx 'height txth)
    (vlax-put mtx 'attachmentpoint 4)
    (entdel pl)
    )
  (setvar "clayer" "0")
  (vla-regen adoc 0)
  (*error* nil)
  (princ)
  )
;;-----------------------------------------------------------------------;;

[dew]

Олег спасибо уже дело сдвинулось..
только :
из серьезных недочетов - 1) не работает с отрезками и дугами и другими...
2) что-то с масштабами не то , работает только при 1.0
(

[Олег (jr.)]

Я не силен в математике, с масштабами вообще дела не имел
Насчет отрезков не пробовал, посмотрю, может что получится

Попробуй будет работать с отрезками

Код:

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

(defun C:AVL(/ acsp adoc ar height ht mtx pl plobj pt room sc txth vol)
  (vl-load-com)
(defun *error* (msg)
      (vla-endundomark (vla-get-activedocument
              (vlax-get-acad-object))
	      )
    (cond ((or (not msg)
	       (member msg '("console break" "Function cancelled" "quit / exit abort"))
	       )
	   )
	  ((princ (strcat "\nError: " msg)))
	  )
(setvar "cmdecho" 1)
    (princ)
    )
 
;;------------------------------ main part -------------------------------;;
  
(setq adoc (vla-get-activedocument
              (vlax-get-acad-object))
      acsp (vla-get-block(vla-get-activelayout adoc))) 
  (vla-startundomark adoc )  
  (setvar "cmdecho" 0)

  (initget 6)
  (setq txth (getreal (strcat "\nEnter text height for label <" (rtos(getvar "dimtxt")) ">: ")))
  (cond ((/= txth 2.5)(setq txth 2.5)))
  
  (initget 1 "1 0.1 0.01 0.001")
  (setq sc (getreal "\nScale [1/0.1/0.01/0.001] < 0.01 > : "))
  (while (setq pt (getpoint "\nPick point inside (or press Enter to Exit): "))

    (vl-cmdf "bpoly" pt "")
    (setq pl (entlast))
    (setq room (getstring T "\nType room name: "))
    (setq height (strcat "H = " (rtos (setq ht (getreal  "\nType room height: ")) 2 2)))

    (setq plobj (vlax-ename->vla-object pl))
    (setq ar (vla-get-area plobj))
    (setq vol (rtos (* (expt sc 3)(* ht ar)) 2 2))
    (setvar "clayer" "0")			  ;<-- set text layer here
    (setq mtx (vlax-invoke
		acsp
		'addmtext
		pt
		0.0
		(strcat "\\A1;" room "\\P" height "\\P" vol " м{\\H0.5x;\\S3;}")))
		
    (vlax-put mtx 'height txth)
    (vlax-put mtx 'attachmentpoint 4)
    (entdel pl)
    )
  (setvar "clayer" "0")
  (vla-regen adoc 0)
  (*error* nil)
  (princ)
  )

~'o'~

[dew]

Совсем не работает (((
Error: Настройка переменной AutoCAD отвергнута: "clayer" "Defpoints"

[Олег (jr.)]

Пробуй опять, удалил

[dew]

с отрезками не хочет работать - Error: ActiveX Server возвратил ошибку: неизвестное имя: Area а с квадратом работает (((
а нельзя ли просто лисп который я выкладывал в начале дополнить вводом высоты помещения и перемножить его в формуле на площадь ?

[Олег (jr.)]

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

[dew]

нет не работает (((

[dew]

Ребята а можно под 2015 автокад исправить кода а то виснет (((

[skkkk]

Какого кода?