[dextron3]

Описание:

1) Выделяем группу замкнутых объектов, не обязательно полилайн или прямоугольных а состоящих из приметивов, замкнутые объекты подсвечиваются для того чтобы контролировать какие объекты войдут в подсчет площади (как в спдс) и в программной строке выводилась общая площадь только в метрах а не в миллиметрах

Алгоритм:

2) Гдето видел такой лисп в форуме но он был без подсветки, и для замкнутых полилайнов и прямоугольников, а не для приметивов

Для чего нужен:

3) Для подсчета объема бетона в Диафрагмах жесткости, ну и для архитекторов

Как без него обойтись:

4) Проставляются отдельно площади, затем взрываются, и суммируются

[ATTACH]1183877955.JPG[/ATTACH]

:roll: :roll: :roll:

[Profan]

не обязательно полилайн или прямоугольных а состоящих из приметивов

Плохое условие.

[dextron3]

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

[Alaspher]

Сообщение от dextron3 А допустим если лисп будет находить замкнутые приметивы и превращать их в полигоны, высчитывать площадь и удалять

Такой лисп уже есть, см. тут последний на странице.

[DonJad]

Такой лисп уже есть, см. тут последний на странице.

дает
:?

23.01.2007 Обновление сайта временно приостановлено. О возобновлении будет сообщено.

[shnn]

Взял сегодня на вышеуказанном сайте.
[ATTACH]1183976383.rar[/ATTACH]

[dextron3]

• Command: parea
  
  Кликни внутри:
  1 loop extracted.
  
  
  1 Region created.
  
  BOUNDARY created 1 region
  Намерял: 34202257 квадратных единиц AutoCAD'а

Это обычная считалка площади
мне нужно чтобы считала сумму площадей всех островков в выделении
а не область между остравками [sm1001]

[dextron3]

pl_copytr(0.9) а этот лисп по типа ДИВАЙД, только вместо точек объект

[Аshаs-ка]

Их есть у нас.
То есть у Апельсинова есть.

Код:

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

;;;Программка подсчета площади по точке внутри контура
;;;Apelsinov 27.12.04
(defun c:are (/		    g-point	  obj-old	obj-new	      area	    hat
	      lay	    olderr	  v-obj-new	summ_area     ap-are-objects-erase
	      ap-sysvariable		  *ERROR*
	     )

;;;Переопределенная функция обработки ошибок
;;;msg - возвращенная строка об ошибке
  (DEFUN *ERROR* (msg)
    (Local_TOOLS ap-are-objects-erase ap-sysvariable)
    (IF	(/= msg "quit / exit abort")
      (PRINC (STRCAT "\n local error:" msg))
      (princ "*Cancel*")
    )
    (princ)
  )

;;;Восстановление данных
;;;ap-are-objects-erase - список созданных обьектов для удаления
;;;ap-sysvariable - список используемых сист. переменных для восстановления
  (DEFUN Local_TOOLS (ap-are-objects-erase ap-sysvariable)
    (if	ap-sysvariable
      (mapcar '(lambda (i) (setvar (car i) (cdr i)))
	      ap-sysvariable
      )
    )
    (if	ap-are-objects-erase
      (mapcar 'vla-delete (apply 'append ap-are-objects-erase))
    )
  )

  (setq obj-old (entlast))					 ;сохранение имени предыдущего созданного обьекта
  (setq	ap-sysvariable						 ; сохранение системных переменных 
	 (mapcar '(lambda (i) (cons i (getvar i)))
		 '("cmdecho" "measurement" "HPBOUND")
	 )
  )
  (begin-activex)						 ; глоб. переменные документа см. begin-activex
  (if (setq lay (clayer_on_locked))				 ; проверка текущего слоя см. clayer_on_locked
    (princ (strcat "\nProblem:" lay))
    (progn
      (setvar "cmdecho" 0)					 ;Отключение вывода сообщений
      (setvar "measurement" 1)					 ; Установка размерности единиц
      (setvar "HPBOUND" 0)					 ; для создания ком. boundary региона
      (while (setq g-point (getpoint "\n Select internal point:"))
	(if (VL-CMDF "_.BOUNDARY" "A" "I" "N" "N" "" g-point "") ; Запуск команды boundary (сщздание региона по точке в контуре)
	  (progn
	    (if	(not (eq (setq obj-new (entlast)) obj-old))
								 ; Сравнение созданного обьекта с предыдущим
	      (progn
		(setq v-obj-new	(vlax-ename->vla-object obj-new)
								 ; Преобразование региона во vla обьект
		      area (vla-get-area v-obj-new)
								 ; Нахождение площади региона
		      hat (add-hat-region v-obj-new (/ (sqrt area) 200))
								 ; Отрисовка штриховки в регионе см. add-hat-region 
		      ap-are-objects-erase
		       (cons (list hat v-obj-new) ap-are-objects-erase)
								 ; Создание списка обьектов для последующего удаления см. Local_TOOLS
		      obj-old (entlast)
		)
		(princ)
		(setq summ_area	(cond (summ_area (+ summ_area area))
				      (area)
				)
		)
	      )
	      (Alert (princ "\n Error! The border is not closed!"))
								 ; Сообщение при равенстве предыдущего обьекта с созданным
	    )
	  )
	)
      )
      (if summ_area 
	(princ (ARE_DCL summ_area))
      )								 ; Запуск диалога с выводом площади))
    )
  )
  (Local_TOOLS ap-are-objects-erase ap-sysvariable)		 ; Восстановление данных и удаление обьектов
  (princ)
)


;;;begin-activex - Создание глобальных переменных для текущего документа
;;;аргументов нет
(defun BEGIN-ACTIVEX (/)
  (vl-load-com)
  (setq acad_application (vlax-get-acad-object))
  (setq active_document (vla-get-activedocument acad_application))
  (setq model_space (vla-get-modelspace active_document))
  (setq paper_space (vla-get-paperspace active_document))
)

;;;Создание штриховки по области региона
;;;obj-new - vla обьект - region
;;;scal - масштаб штриховки 
(defun ADD-HAT-REGION (obj-new scal / hat doc)
  (vla-AppendInnerLoop
    (setq hat (vla-addHatch
		(if (and (zerop
			   (vla-get-activespace
			     (setq doc (vla-get-activedocument (vlax-get-acad-object)))
			   )
			 )
			 (= :vlax-false (vla-get-mspace doc))
		    ) ;_ end of and
		  (vla-get-paperspace doc)
		  (vla-get-modelspace doc)
		)
		acHatchPatternTypePredefined
		"ANSI31"
		:vlax-false
	      )
    )
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbobject (cons 0 0))
      (list obj-new)
    )
  )
  (vla-put-patternscale hat scal)
  (vla-put-patternangle hat 0)
  (vla-put-hatchstyle hat achatchstylenormal)
  (vla-evaluate hat)
  (eval hat)
)

;;;Функция обработки диалога are
;;;area - значение площади -вещ. число
;;;Возвр:  Строка значения площади "Area:  [...м2]"
(defun ARE_DCL (area / strArea list_textset)
  (if
    (and (>= (setq dcl_id (load_dialog "are.dcl")) 0)
	 (new_dialog "are" dcl_id)
    )
     (progn
       (set_tile "text"
		 (setq strArea (strcat "\n Area: "
				       (rtos area 2 2)
				       "\n["
				       (rtos (* 0.000001 area) 2 2)
				       " м2]"
			       )
		 )
       )

       (action_tile "ok" "(setq area nil)(done_dialog)")
       (setq list_textset
	      (list
		(getvar "textsize")
		(getvar "textstyle")
		((lambda (i)
		   (atoi (cond ((eq i "BYLAYER") "256")
			       ((eq i "BYBLOCK") "0")
			       (i)
			 )
		   )
		 )
		  (getvar "cecolor")
		)
	      )
       )
       (action_tile
	 "ttools"
	 "(if (setq l_textset (apply 'textset list_textset))(progn
	 (setq list_textset (mapcar 'cdr l_textset))
	 (mapcar 'setvar '(\"textsize\" \"textstyle\" \"cecolor\")
	                  ((lambda (i) (reverse (cons (rtos (last i) 2 0)(cdr (reverse i)))))
	                  list_textset))))"
       )
       (action_tile
	 "ins"
	 "(done_dialog)"
       )
       (START_DIALOG)
       (UNLOAD_DIALOG dcl_id)
       (if area
	 (apply	'incert-text
		(cons (rtos (* 0.000001 area) 2 2) list_textset)
	 )
       )
       (eval strArea)
     )
  )
)

;;;Вставка текста
;;;text - строка текста
;;;h - высота текста
;;;style - стиль
;;;color - цвет текста

(defun incert-text (text h style color / point v-text)
  (if (and (setq point (vlax-3d-point (getpoint "\nSpecify start point of text:")))
	   (setq v-text (vla-addtext model_space text point h))
      )
    (vla-put-color v-text color)
    (if	(tblsearch "style" style)
      (vla-put-stylename v-text style)
    )
  )
)

;;;----------------------------------
(defun textset
	       (textheight textstyle apcol / dtextset A	st image aptextset imagcol)

;;; imagcol - закраска кнопки цветом
;;;apcol - цвет - целое число
;;;image - имя кнопки - строка
  (defun imagcol (apcol image)
    (start_image image)
    (fill_image
      1
      1
      (- (dimx_tile image) 2)
      (- (dimy_tile image) 2)
      apcol
    )
    (end_image)
  )

  (if
    (and (>= (setq dtextset (load_dialog "textset.dcl")) 0)
	 (new_dialog "textset" dtextset)
    )
     (progn
;;; Textstyle
       (IMAGCOL apcol "image")
       (start_list "textstyle" 3)
       (vlax-for i (vla-get-textstyles
		     (vla-get-ActiveDocument
		       (vlax-get-acad-object)
		     )
		   )
	 (setq st (cons (vla-get-name i) st))
       )
       (mapcar 'add_list st)
       (end_list)
       (set_tile "textstyle"
		 (rtos (vl-position textstyle (reverse st)) 2 0)
       )
       (set_tile "textheidht" (rtos textheight 2 0))
;;; Textheight
       (action_tile
	 "textheidht"
	 "(if (or (<= (atoi $value) 0)) (progn
	    (alert \"Invalid height!\")
	    (mode_tile \"textheidht\" 2))))"
       )
;;;color
       (action_tile
	 "image"
	 "(if (setq A (acad_colordlg apcol))
           (imagcol (setq apcol A) \"image\"))"
       )
;;;ok
       (action_tile
	 "ok"
	 "(setq aptextset (list (cons \"height\" (atof (get_tile \"textheidht\")))
			       (cons \"style\"
				     (nth (atoi (get_tile \"textstyle\")) (reverse st))
			       )
			       (cons \"color\" apcol)
			 )
	 )
	 (done_dialog)"
       )
       (start_dialog)
       (unload_dialog dtextset)
       (eval 'aptextset)
     )
  )
)

;;;Проверка текущего слоя на вкл. и заблокирован
;;;аргументов нет
;;;Возвращает строку о выкл или заблокирован или nil если нет
(defun clayer_on_locked	(/ layer str)
  (cond
    ((eq (vla-get-layeron
	   (setq layer (vla-get-ActiveLayer
			 (vla-get-ActiveDocument
			   (vlax-get-acad-object)
			 )
		       )
	   )
	 )
	 :vlax-false
     )
     "The current layer is turned off"
    )

    ((eq (vla-get-Lock layer) :vlax-true)
     "The current layer locked"
    )
  )
)
(princ "\nLoading the command: ARE")
(princ)

И к нему  DCL:

are: dialog {label = "Area";
:column {
:text {key="text";width=20 ;height=4; value="Text: 1233.1221\n (12345)";}
:row {
:column {
:button {label= "Insert text";key="ins";}
:button {label= "Text tools";key="ttools";}
}
:ok_button {label= "OK";is_default=true;height=4; key="ok";}
}}}

Оченно даже хорошо работает, и не по одному, а суммирует площади. И в квадратных метрах!

[dextron3]

Command: ARE

Select internal point:
1 loop extracted.


1 Region created.

BOUNDARY created 1 region
Select internal point:
1 loop extracted.


1 Region created.

BOUNDARY created 1 region
Select internal point:
1 loop extracted.


1 Region created.

BOUNDARY created 1 region
Select internal point:
nil

что то не работает

[Аshаs-ка]

А правой клавишей мышки пискнуть не пробовали? Все работает! Еще спросит, куда записать, еще и штриховку удалит, только высота текста текущая, следить надо за размером!

[Аshаs-ка]

А файл диалогового окна переписали-с?
А are.lsp и are.dcl их обозвали?
nul похоже срабатывает при обращении к диалоговому окну...

[CB]

И к нему DCL: are: dialog {label = "Area"; :column { :text {key="text";width=20 ;height=4; value="Text: 1233.1221\n (12345)";} :row { :column { :button {label= "Insert text";key="ins";} :button {label= "Text tools";key="ttools";} } k_button {label= "OK";is_default=true;height=4; key="ok";} }}}

Это надо сохранить в отдельном файле are.dcl, естественно в путях поддержки ACAD :?

[dextron3]

Сообщение от Аshаs-ка А файл диалогового окна переписали-с? А are.lsp и are.dcl их обозвали? nul похоже срабатывает при обращении к диалоговому окну...

А вот теперь работает!!!

[sm166]

Ято лисп до конца не дочитал, уж больно длинный

Спасибо!

[Аshаs-ка]

Да чего уж там! Спасибо Апельсинову!...