LISP "are - расчет площади замкнутого контура" + русский ACAD2008
| Правила | Регистрация | Пользователи | Сообщения за день |  Справка по форуму | Файлообменник |

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

LISP "are - расчет площади замкнутого контура" + русский ACAD2008

Ответ
Перейти к новому Перейти к новому  
Поиск в этой теме
Непрочитано 24.03.2008, 15:35 #1
LISP "are - расчет площади замкнутого контура" + русский ACAD2008
Алекс
 
Регистрация: 10.12.2004
Сообщений: 636
Любимый 3й год подряд are перестал работать в русском 2008м
Цитата:
Команда: _are
Select internal point:
Требуется 2D точка или ключевое слово.
Требуется 2D точка или ключевое слово.
Требуется 2D точка или ключевое слово.
Требуется 2D точка или ключевое слово.
Извлечено: 0 замкнутых контуров
Создано: 0 области(ей).
Неизвестная команда "ARE". Для вызова справки нажмите F1.
Error! The border is not closed!
Указание точки даже внутри свеженарисованой окружности -> Error! The border is not closed!
Я так понимаю это из-за того, что АКАД русский. Можно подредактировать?
Просмотров: 6122
 
Непрочитано 24.03.2008, 16:30
#2
Кулик Алексей aka kpblc
Moderator

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

Попробуй заменить lsp на следующий вид:
Код:
[Выделить все] 
;;;Программка подсчета площади по точке внутри контура
(princ "\nLoading the command: ARE")
(princ)
;;;Apelsinov 28.04.05
;;;apelsinov@pochta.ru
(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)
    (princ msg)
    (princ)
    ) ;_ end of defun

;;;Восстановление данных
;;;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
              ) ;_ end of mapcar
      ) ;_ end of if
    (if ap-are-objects-erase
      (mapcar 'vla-delete (apply 'append ap-are-objects-erase))
      ) ;_ end of if
    ) ;_ end of DEFUN

  (setq obj-old (entlast)) ;сохранение имени предыдущего созданного обьекта
  (setq ap-sysvariable ; сохранение системных переменных 
         (mapcar '(lambda (i) (cons i (getvar i)))
                 '("cmdecho" "measurement" "HPBOUND")
                 ) ;_ end of mapcar
        ) ;_ end of setq
  (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)
                  ) ;_ end of setq
                (princ)
                (setq area_list (cons area area_list)
          ; Создание списка площадей
                      ) ;_ end of setq
                ) ;_ end of progn
              (alert (princ "\n Error! The border is not closed!"))
          ; Сообщение при равенстве предыдущего обьекта с созданным
              ) ;_ end of if
            ) ;_ end of progn
          ) ;_ end of if
        ) ;_ end of while
      ) ;_ end of progn
    ) ;_ end of if
  (if area_list
    (princ (strcat "\n*********************"
                   (are_dcl (apply (function +) area_list))
                   "\n*********************"
                   (ap_are_arealist_princ (reverse area_list))
                   "\n*********************"
                   ) ;_ end of strcat
           ) ;_ end of princ
          ; Запуск диалога с выводом площади в т.ч в ком строку и по каждому контуру отдельно
    ) ;_ end of if
  (local_tools ap-are-objects-erase ap-sysvariable)
          ; Восстановление данных и удаление обьектов
  (princ)
  ) ;_ end of defun

;;;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))
  ) ;_ end of defun

;;;Создание штриховки по области региона
;;;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)
                                         ) ;_ end of vla-get-activedocument
                                   ) ;_ end of setq
                             ) ;_ end of vla-get-activespace
                           ) ;_ end of zerop
                         (= :vlax-false (vla-get-mspace doc))
                         ) ;_ end of and
                  (vla-get-paperspace doc)
                  (vla-get-modelspace doc)
                  ) ;_ end of if
                achatchpatterntypepredefined
                "ANSI31"
                :vlax-false
                ) ;_ end of vla-addHatch
          ) ;_ end of setq
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbobject (cons 0 0))
      (list obj-new)
      ) ;_ end of vlax-safearray-fill
    ) ;_ end of vla-AppendInnerLoop
  (vla-put-patternscale hat scal)
  (vla-put-patternangle hat 0)
  (vla-put-hatchstyle hat achatchstylenormal)
  (vla-evaluate hat)
  (eval hat)
  ) ;_ end of defun

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

       (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)
                               ) ;_ end of cond
                         ) ;_ end of atoi
                   ) ;_ end of lambda
                  (getvar "cecolor")
                  )
                ) ;_ end of list
             ) ;_ end of setq
       (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))))"
         ) ;_ end of action_tile
       (action_tile
         "ins"
         "(done_dialog)"
         ) ;_ end of action_tile
       (start_dialog)
       (unload_dialog dcl_id)
       (if area
         (apply 'incert-text
                (cons (rtos (* 0.000001 area) 2 2) list_textset)
                ) ;_ end of apply
         ) ;_ end of if
       (eval strarea)
       ) ;_ end of progn
     (progn (princ "\n File are.dcl is not found!")
            strarea
            ) ;_ end of progn
     ) ;_ end of if
  ) ;_ end of defun

;;;Вставка текста
;;;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:")
                         ) ;_ end of vlax-3d-point
                 ) ;_ end of setq
           (setq v-text (vla-addtext model_space text point h))
           ) ;_ end of and
    (vla-put-color v-text color)
    (if (tblsearch "style" style)
      (vla-put-stylename v-text style)
      ) ;_ end of if
    ) ;_ end of if
  ) ;_ end of defun

;;;----------------------------------
(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 of fill_image
    (end_image)
    ) ;_ end of defun

  (if
    (and (>= (setq dtextset (load_dialog "textset.dcl")) 0)
         (new_dialog "textset" dtextset)
         ) ;_ end of and
     (progn
;;; Textstyle
       (imagcol apcol "image")
       (start_list "textstyle" 3)
       (vlax-for i (vla-get-textstyles
                     (vla-get-activedocument
                       (vlax-get-acad-object)
                       ) ;_ end of vla-get-ActiveDocument
                     ) ;_ end of vla-get-textstyles
         (setq st (cons (vla-get-name i) st))
         ) ;_ end of vlax-for
       (mapcar 'add_list st)
       (end_list)
       (set_tile "textstyle"
                 (rtos (vl-position textstyle (reverse st)) 2 0)
                 ) ;_ end of set_tile
       (set_tile "textheidht" (rtos textheight 2 0))
;;; Textheight
       (action_tile
         "textheidht"
         "(if (or (<= (atoi $value) 0)) (progn
	    (alert \"Invalid height!\")
	    (mode_tile \"textheidht\" 2))))"
         ) ;_ end of action_tile
;;;color
       (action_tile
         "image"
         "(if (setq A (acad_colordlg apcol))
           (imagcol (setq apcol A) \"image\"))"
         ) ;_ end of action_tile
;;;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)"
         ) ;_ end of action_tile
       (start_dialog)
       (unload_dialog dtextset)
       (eval 'aptextset)
       ) ;_ end of progn
     ) ;_ end of if
  ) ;_ end of defun

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

;;;Создание строки для вывода площадей по каждому контуру
;;;    Арнументы: список площадей
(defun ap_are_arealist_princ (area_list /)
  (apply
    (function strcat)
    (cons "\nacad_units / m2"
          (mapcar
            (function
              (lambda (area)
                (strcat "\n"
                        (rtos area 2 2)
                        " / "
                        (rtos (* area 0.000001) 2 2)
                        ) ;_ end of strcat
                ) ;_ end of lambda
              ) ;_ end of function
            area_list
            ) ;_ end of mapcar
          ) ;_ end of cons
    ) ;_ end of apply
  ) ;_ end of defun
P.S. Код не гонял и не проверял - исправил тлько явные ошибки.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 24.03.2008, 17:44
#3
Алекс


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

Заработало!!! Огромное спасибо!
Алекс вне форума  
 
Непрочитано 24.05.2008, 13:57
#4
MindWork


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

Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
Попробуй заменить lsp на следующий вид:
Код:
[Выделить все] 
;;;Программка подсчета площади по точке внутри контура
(princ "\nLoading the command: ARE")
(princ)
;;;Apelsinov 28.04.05
;;;apelsinov@pochta.ru
(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)
    (princ msg)
    (princ)
    ) ;_ end of defun

;;;Восстановление данных
;;;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
              ) ;_ end of mapcar
      ) ;_ end of if
    (if ap-are-objects-erase
      (mapcar 'vla-delete (apply 'append ap-are-objects-erase))
      ) ;_ end of if
    ) ;_ end of DEFUN

  (setq obj-old (entlast)) ;сохранение имени предыдущего созданного обьекта
  (setq ap-sysvariable ; сохранение системных переменных 
         (mapcar '(lambda (i) (cons i (getvar i)))
                 '("cmdecho" "measurement" "HPBOUND")
                 ) ;_ end of mapcar
        ) ;_ end of setq
  (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)
                  ) ;_ end of setq
                (princ)
                (setq area_list (cons area area_list)
          ; Создание списка площадей
                      ) ;_ end of setq
                ) ;_ end of progn
              (alert (princ "\n Error! The border is not closed!"))
          ; Сообщение при равенстве предыдущего обьекта с созданным
              ) ;_ end of if
            ) ;_ end of progn
          ) ;_ end of if
        ) ;_ end of while
      ) ;_ end of progn
    ) ;_ end of if
  (if area_list
    (princ (strcat "\n*********************"
                   (are_dcl (apply (function +) area_list))
                   "\n*********************"
                   (ap_are_arealist_princ (reverse area_list))
                   "\n*********************"
                   ) ;_ end of strcat
           ) ;_ end of princ
          ; Запуск диалога с выводом площади в т.ч в ком строку и по каждому контуру отдельно
    ) ;_ end of if
  (local_tools ap-are-objects-erase ap-sysvariable)
          ; Восстановление данных и удаление обьектов
  (princ)
  ) ;_ end of defun

;;;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))
  ) ;_ end of defun

;;;Создание штриховки по области региона
;;;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)
                                         ) ;_ end of vla-get-activedocument
                                   ) ;_ end of setq
                             ) ;_ end of vla-get-activespace
                           ) ;_ end of zerop
                         (= :vlax-false (vla-get-mspace doc))
                         ) ;_ end of and
                  (vla-get-paperspace doc)
                  (vla-get-modelspace doc)
                  ) ;_ end of if
                achatchpatterntypepredefined
                "ANSI31"
                :vlax-false
                ) ;_ end of vla-addHatch
          ) ;_ end of setq
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbobject (cons 0 0))
      (list obj-new)
      ) ;_ end of vlax-safearray-fill
    ) ;_ end of vla-AppendInnerLoop
  (vla-put-patternscale hat scal)
  (vla-put-patternangle hat 0)
  (vla-put-hatchstyle hat achatchstylenormal)
  (vla-evaluate hat)
  (eval hat)
  ) ;_ end of defun

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

       (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)
                               ) ;_ end of cond
                         ) ;_ end of atoi
                   ) ;_ end of lambda
                  (getvar "cecolor")
                  )
                ) ;_ end of list
             ) ;_ end of setq
       (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))))"
         ) ;_ end of action_tile
       (action_tile
         "ins"
         "(done_dialog)"
         ) ;_ end of action_tile
       (start_dialog)
       (unload_dialog dcl_id)
       (if area
         (apply 'incert-text
                (cons (rtos (* 0.000001 area) 2 2) list_textset)
                ) ;_ end of apply
         ) ;_ end of if
       (eval strarea)
       ) ;_ end of progn
     (progn (princ "\n File are.dcl is not found!")
            strarea
            ) ;_ end of progn
     ) ;_ end of if
  ) ;_ end of defun

;;;Вставка текста
;;;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:")
                         ) ;_ end of vlax-3d-point
                 ) ;_ end of setq
           (setq v-text (vla-addtext model_space text point h))
           ) ;_ end of and
    (vla-put-color v-text color)
    (if (tblsearch "style" style)
      (vla-put-stylename v-text style)
      ) ;_ end of if
    ) ;_ end of if
  ) ;_ end of defun

;;;----------------------------------
(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 of fill_image
    (end_image)
    ) ;_ end of defun

  (if
    (and (>= (setq dtextset (load_dialog "textset.dcl")) 0)
         (new_dialog "textset" dtextset)
         ) ;_ end of and
     (progn
;;; Textstyle
       (imagcol apcol "image")
       (start_list "textstyle" 3)
       (vlax-for i (vla-get-textstyles
                     (vla-get-activedocument
                       (vlax-get-acad-object)
                       ) ;_ end of vla-get-ActiveDocument
                     ) ;_ end of vla-get-textstyles
         (setq st (cons (vla-get-name i) st))
         ) ;_ end of vlax-for
       (mapcar 'add_list st)
       (end_list)
       (set_tile "textstyle"
                 (rtos (vl-position textstyle (reverse st)) 2 0)
                 ) ;_ end of set_tile
       (set_tile "textheidht" (rtos textheight 2 0))
;;; Textheight
       (action_tile
         "textheidht"
         "(if (or (<= (atoi $value) 0)) (progn
	    (alert \"Invalid height!\")
	    (mode_tile \"textheidht\" 2))))"
         ) ;_ end of action_tile
;;;color
       (action_tile
         "image"
         "(if (setq A (acad_colordlg apcol))
           (imagcol (setq apcol A) \"image\"))"
         ) ;_ end of action_tile
;;;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)"
         ) ;_ end of action_tile
       (start_dialog)
       (unload_dialog dtextset)
       (eval 'aptextset)
       ) ;_ end of progn
     ) ;_ end of if
  ) ;_ end of defun

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

;;;Создание строки для вывода площадей по каждому контуру
;;;    Арнументы: список площадей
(defun ap_are_arealist_princ (area_list /)
  (apply
    (function strcat)
    (cons "\nacad_units / m2"
          (mapcar
            (function
              (lambda (area)
                (strcat "\n"
                        (rtos area 2 2)
                        " / "
                        (rtos (* area 0.000001) 2 2)
                        ) ;_ end of strcat
                ) ;_ end of lambda
              ) ;_ end of function
            area_list
            ) ;_ end of mapcar
          ) ;_ end of cons
    ) ;_ end of apply
  ) ;_ end of defun
P.S. Код не гонял и не проверял - исправил тлько явные ошибки.
AutoCad 2008 Rus
lisp работает, но иногда создаёт резаные копии контура, можно это поправить?
MindWork вне форума  
 
Непрочитано 25.05.2008, 00:33
#5
Кулик Алексей aka kpblc
Moderator

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

Я не автор и времени разбираться с кодом у меня нет совсем. Я свои-то "творения" иногда победить не могу...
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 25.05.2012, 16:17
#6
Хмурый


 
Регистрация: 29.10.2004
СПб
Сообщений: 16,379

может, у кого-нибудь есть файлик TEXTSET.DCL - диалоговое окно для команды Text Tool для этой программы ARE?
Выложите, пожалуйста... Или Апельсинова дёргать?
Последний раз редактировалось Хмурый, 25.05.2012 в 19:35.
Хмурый вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > LISP "are - расчет площади замкнутого контура" + русский ACAD2008



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
LISP. Вставка в таблицу поля, соотвествующего площади примитива Profan Готовые программы 272 06.06.2021 23:12
Фундамент с динамическими нагрузками в Scad Tlelaxu SCAD 9 31.08.2007 10:44

Обратная связь - Вверх