;;;Программка подсчета площади по точке внутри контура
(princ "\nLoading the command: ARE")
(princ)
(prompt "\n Area Clculating Lisp 2010")

(defun c:are (/ g-point obj-old obj-new
area hat lay olderr
v-obj-new area_list 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 area_list (cons area area_list)
; Создание списка площадей
)
)
(Alert (princ "\n Error! The border is not closed!"))
; Сообщение при равенстве предыдущего обьекта с созданным
)
)
)
)
)
)
(if area_list
(princ (strcat "\n*********************"
(ARE_DCL (apply (function +) area_list))
"\n*********************"
(AP_ARE_AREALIST_PRINC (reverse area_list))
"\n*********************"
)
)
; Запуск диалога с выводом площади в т.ч в ком строку и по каждому контуру отдельно
)
(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: [...M2]"
(defun ARE_DCL (area / strArea list_textset)
(setq strArea (strcat "\n Total Area: "
(rtos area 2 2)
"\n"
; (rtos (* 1 area) 2 2)
""
)
)
(if
(and (>= (setq dcl_id (load_dialog "are.dcl")) 0)
(new_dialog "are" dcl_id)
)
(progn
(set_tile "text"
strArea
)

(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 (* 1 area) 2 2) list_textset)
)
)
(eval strArea)
)
(progn (princ "\n File are.dcl is not found!")
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"
)
)
)

;;;Создание строки для вывода площадей по каждому контуру
;;; Арнументы: список площадей
(defun AP_ARE_AREALIST_PRINC (area_list /)
(apply
(function strcat)
(cons "\nArea List"
(mapcar
(function
(lambda (area)
(strcat "\n"
(rtos area 2 2)
" ***** "
(rtos (* area 1) 2 2)
)
)
)
area_list
)
)
)
)
(c:are)

Advertisements