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

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

Помогите подкорректировать лисп "подсчета площади по точке внутри контура"

Ответ
Поиск в этой теме
Непрочитано 27.10.2019, 19:12 #1
Помогите подкорректировать лисп "подсчета площади по точке внутри контура"
dextron3
 
проектировшик
 
СССР
Регистрация: 01.01.2007
Сообщений: 5,143

Всем привет, вспомнил про этот давно забытый лисп, который считает площадь по точки внутри контура, но когда внутри контура находится остров, он его не замечает, а когда полуостров то замечает, чувствую нужно что-то подправить чтобы он не учитывал площадь островов внутри фигуры, но не пойму где,

заранее благодарен

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

;;;Программка подсчета площади по точке внутри контура 
;;;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) 


Миниатюры
Нажмите на изображение для увеличения
Название: Захват4.jpg
Просмотров: 36
Размер:	236.5 Кб
ID:	219415  Нажмите на изображение для увеличения
Название: Захват5.jpg
Просмотров: 38
Размер:	225.6 Кб
ID:	219416  

__________________
инженер проектировшик с опттом программа авто гад образование высшие
Просмотров: 2775
 
Непрочитано 30.10.2019, 12:57
#2
Vladimir_Sergeevich

рисую дороги, в перерывах курю Lisp
 
Регистрация: 20.04.2011
Пермь
Сообщений: 475
<phrase 1= Отправить сообщение для Vladimir_Sergeevich с помощью Skype™


После (VL-CMDF "_.BOUNDARY" "A" "I" "N" "N" "" g-point "")
Обрабатывается только один объект (setq obj-new (entlast))

С такой логикой программа ничего другого не выдаст.
Вариант на подумать попроще - заменить _-boundary на _-hatch и обрабатывать штриховку полученную
Вариант посложнее - углубить поиск свежесозданных контуров и вычитать их площади из основного со всеми вытекающими OuterLoop'ами для штриховки
Вариант еще сложнее - писать свой собственный аналог _boundary который будет выдавать желаемое без использования командных методов вообще

з.ы. какой странный объект этот ваш IAcadRegion. похоже с ним ни Lisp ни ActivX не совладает...
__________________
Не труд сделал из обезьяны человека, а лень и жажда халявы...

Последний раз редактировалось Vladimir_Sergeevich, 30.10.2019 в 13:17.
Vladimir_Sergeevich вне форума  
 
Непрочитано 30.10.2019, 13:22
#3
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Цитата:
Сообщение от Vladimir_Sergeevich Посмотреть сообщение
з.ы. какой странный объект этот ваш IAcadRegion. похоже с ним ни Lisp ни ActivX не совладает...
А что ты с ним хочешь сделать?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 30.10.2019, 13:51
#4
Vladimir_Sergeevich

рисую дороги, в перерывах курю Lisp
 
Регистрация: 20.04.2011
Пермь
Сообщений: 475
<phrase 1= Отправить сообщение для Vladimir_Sergeevich с помощью Skype™


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
А что ты с ним хочешь сделать?
Я? вообще ничего, не хочу, первый раз увидел и вряд-ли когда нибудь буду использовать. Там конечно есть любопытные свойства типа момента инерции и чего то там еще. Но кроме как его создать или удалить, больше с ним ничего и не сделать. Даже за ручки контур не изменить.
__________________
Не труд сделал из обезьяны человека, а лень и жажда халявы...
Vladimir_Sergeevich вне форума  
 
Непрочитано 30.10.2019, 14:08
#5
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Типа руками у региона можно поменять ручки?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 30.10.2019, 15:45
#6
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


По сути это программное свойство _.BOUNDARY именно не учитывать островные приметивы, вопрос на засыпку есть ли аналог этой наиудобнейшей программы, неужели никто не считал площадь разрозненных фигур ранее, но естественно без полей и таблиц, спросите где это нужно, да к примеру теже монолитные участки в пустотных плитах перекрытия
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 30.10.2019, 18:17
#7
Alex.gomel


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


По существу вопроса, без шлифовки:

Код:
[Выделить все]
 ;;;Программка подсчета площади по точке внутри контура 
;;;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 "_-hatch" 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 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) 
Alex.gomel вне форума  
 
Автор темы   Непрочитано 31.10.2019, 06:15
#8
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


Сообщение при нажатие внутри любой фигуры: Error! The border is not closed!
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 31.10.2019, 11:02
#9
koMon


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


Цитата:
Сообщение от dextron3 Посмотреть сообщение
лисп, который считает площадь по точки внутри контура
Код:
[Выделить все]
 
;**************************************************************************************************************************************************

(defun c:Sum_Area (/ found_boundary_object closed_boundary_hatch area_index getting_area total_area area_index
						  area_object mtext_corner mtext_object reference_object current_hatch_settings
				  )
	(vla-startUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(setq area_index 0
		  getting_area t
		  total_area 0
		  hatches_to_delete_set (ssadd)
	)
	(if (null hatch_color) (setq hatch_color 0))
	(setvar 'cmdecho 0)

	;****************************************************************

	(defun get_current_hatch_settings ()
		(setq current_hatch_settings (list (getvar 'hpassoc)
										   (getvar 'hpcolor)
										   (getvar 'hpislanddetection)
										   (getvar 'hpname)
										   (getvar 'hppickmode)
									 )
		)
	)

	;****************************************************************

	(defun restore_previous_hatch_settings ()
		(setvar 'hpassoc (nth 0 current_hatch_settings))
		(setvar	'hpcolor (nth 1 current_hatch_settings))
		(setvar	'hpislanddetection (nth 2 current_hatch_settings))
		(setvar	'hpname (nth 3 current_hatch_settings))
		(setvar	'hppickmode (nth 4 current_hatch_settings))
	)

	;****************************************************************

	(defun find_closed_boundary ()
		(setq reference_object (vlax-ename->vla-object (entlast))
			  point_inside_area (vl-catch-all-apply 'getpoint (list "\nУкажите точку внутри измеряемой площади: "))
		)
		(cond
			(
				(= (type point_inside_area) 'vl-catch-all-apply-error)
			)
			(
				(null point_inside_area)
					(setq getting_area nil)
			)
			(
				t
					(vl-cmdf "_.-hatch" "_p" "_s" "_co" (if (> (setq hatch_color (1+ hatch_color)) 255) (setq hatch_color 1) hatch_color) "" "_a" "_i" "_y" "" "_a" "_a" "_n" "" point_inside_area "")
					(setq closed_boundary_hatch (vlax-ename->vla-object (entlast)))
					(hatch_to_back)
			)
		)
	)

	;****************************************************************

	(defun hatch_to_back ()
		(if (and
				closed_boundary_hatch
				(= "AcDbHatch" (vla-get-objectname closed_boundary_hatch))
			)
				(progn
					(command "._draworder" (vlax-vla-object->ename closed_boundary_hatch) "" "_b")
					(vla-put-EntityTransparency closed_boundary_hatch "70")
					(setq hatches_to_delete_set (ssadd (vlax-vla-object->ename closed_boundary_hatch) hatches_to_delete_set))

				)
		)
	)

	;****************************************************************
	(get_current_hatch_settings)
	(while getting_area
		(vl-catch-all-apply 'find_closed_boundary)
		(setq found_boundary_object (vlax-ename->vla-object (entlast)))
		(cond
			(
				(null point_inside_area)
			)
			(
				(not (equal reference_object found_boundary_object))
					(setq total_area (+ total_area (vla-get-area found_boundary_object))
						  area_index (1+ area_index)
					)
					(princ (strcat (rtos (* 1e-6 (vla-get-area found_boundary_object)) 2 2) " [" (itoa area_index) "]"))
			)
			(
				(= (type point_inside_area) 'vl-catch-all-apply-error)
					(setq area_object (vl-catch-all-apply 'entsel (list "Продолжить с выбором объекта (ESC для завершения команды): ")))
					(cond
						(
							(= (type area_object) 'vl-catch-all-apply-error)
								(hatch_to_back)
								(setq getting_area nil)
						)
						(
							(= (type area_object) 'list)
								(cond
									(
										(and
											(vlax-property-available-p (setq found_boundary_object (vlax-ename->vla-object (car area_object))) 'area)
											(> (vla-get-area found_boundary_object) 0)
										)
											(vl-cmdf "_.-hatch" "_p" "_s" "_co" (if (> (setq hatch_color (1+ hatch_color)) 255) (setq hatch_color 1) hatch_color) "" "_a" "_a" "_n" "" "_s" (car area_object) "" "")
											(if (not (equal (setq closed_boundary_hatch (vlax-ename->vla-object (entlast))) reference_object))
												(progn
													(setq total_area (+ total_area (vla-get-area closed_boundary_hatch))
														  area_index (1+ area_index)
													)
													(hatch_to_back)
													(princ (strcat (rtos (* 1e-6 (vla-get-area closed_boundary_hatch)) 2 2) " [" (itoa area_index) "]"))
												)
											)
									)
									(
										t
						            		(alert "У выбранного объекта нет свойства \nплощади или она нулевая")
									)
								)
						)
						(
							t
						)
					)
			)
			(
				t
			)
		)
	)
	(princ "\nКоманда прекращена")
	(princ (strcat "\nОбщая площадь выбранных " (itoa area_index) " границ/объектов: " (rtos (* 1e-6 total_area) 2 2) " кв.м"))
	(command "._erase" hatches_to_delete_set "")
	(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(restore_previous_hatch_settings)
	(setvar 'cmdecho 1)
	(princ)
)

;**************************************************************************************************************************************************

Последний раз редактировалось koMon, 05.11.2019 в 10:32.
koMon вне форума  
 
Автор темы   Непрочитано 31.10.2019, 12:53
#10
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


Спасибо, Лисп для архитекторов больше полезен (по сути он аналогичен команде площадь СПДС графикс), мне нужно общую площадь в конце знать из площади выбранных точкой фигур, я конечно могу в каждом приметиве вывести площадь в Вашем лиспе я убрал верхнюю дробь с позициями и потом суммировать другой командой все площади, и потом их удалить, но не вариант, я так же делаю существующей командой
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 01.11.2019, 11:21
#11
koMon


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


Цитата:
Сообщение от dextron3 Посмотреть сообщение
мне нужно общую площадь в конце знать из площади выбранных точкой фигур
я вообще не писал этот лисп для этой темы, просто немного подкорректировал. ранее был такой вопрос - лисп оттуда. обновил #9.
млиния?
koMon вне форума  
 
Автор темы   Непрочитано 01.11.2019, 16:15
#12
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


Спасибо, а можно упростить его, чтобы цифры вообще не выводились на чертеже, а заливка предыдущего оставалась, чтобы видеть объем проделанной работы (защита от дурака), ну и в конце единицы м.кв.
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 01.11.2019, 17:35
#13
koMon


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


Цитата:
Сообщение от dextron3 Посмотреть сообщение
а можно упростить его
ломать - не строить -> #9
koMon вне форума  
 
Автор темы   Непрочитано 01.11.2019, 18:05
#14
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


Лисп в посту 9 остался тот же
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 01.11.2019, 18:53
#15
koMon


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


Ну это очень вряд ли)

----- добавлено через ~2 ч. -----
Команда сменила имя с Area_to_Mtext на Sum_Area
koMon вне форума  
 
Автор темы   Непрочитано 03.11.2019, 14:30
#16
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


Цитата:
Сообщение от koMon Посмотреть сообщение
Ну это очень вряд ли)

----- добавлено через ~2 ч. -----
Команда сменила имя с Area_to_Mtext на Sum_Area
Спасибо!

Можно маленькие изменения добавить: ввести коэфициент чтобы из миллиметров квадратных выводилось в метры *0.000001
и округление до 2х цифр после запятой
ну еще хотелось бы чтобы завершение команды было кнопкой ЕНТЕР, то есть щелкаешь щелкаешь, потом ентер нажимаешь сразу в командной строке площадь и команда завершилась,
ну и самое главное удалилась вся заливка, чтобы ее потом в ручную не удалять,
и убрать разноцветность, только в цвет текущего слоя, а то потом после срабатывания команды заливка сбивается приходится перенастраивать, а так же цвета совпадают с чертежами тоже теряться начинаешь выделял или нет
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 05.11.2019, 10:31
#17
koMon


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


wtff
обновил #9
koMon вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Помогите подкорректировать лисп "подсчета площади по точке внутри контура"

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Как подсчитывается площади общественных и жилых помещений? yannay Прочее. Архитектура и строительство 2 02.01.2014 13:50
LISP "are - расчет площади замкнутого контура" + русский ACAD2008 Алекс LISP 5 25.05.2012 16:17
Нужен ЛИСП на расчет процентного заполнения чертежа краской Малявка LISP 32 04.04.2011 14:21
Кто ("монолитчики" или "те, кто сети внутри здания делают") делает технологические отверстия в монолином ж.б. каркасе здания ? drill_man Прочее. Архитектура и строительство 31 20.12.2010 09:17
Помогите пожалуйста. Нужен лисп. Sleekka LISP 2 24.11.2006 20:58