[ilka_t]

Помогите с Лиспом нужно выбрать полилинии, узнать ее площадь и вставить плщадь в чертеж и желательно с возможностью выбора масштаба

[Кулик Алексей aka kpblc]

http://dwg.ru/search.php?zone=2&mod=...EB%E8%EB%E8%ED
P.S. Если версия от 2005 и выше, можно и такое чудовище попробовать:

Код:

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

(defun c:sq (/ adoc ent pt)
  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-StartUndoMark
  (if
    (and (= (type (setq ent
                         (vl-catch-all-apply
                           '(lambda () (car (entsel "\nУкажите полилинию <Отмена> : ")))
                           ) ;_ end of vl-catch-all-apply
                        ) ;_ end of setq
                  ) ;_ end of type
            'ename
            ) ;_ end of =
         (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
         (/= (logand (cdr (assoc 70 (entget ent))) 129) 0)
         (= (type (setq pt (vl-catch-all-apply
                             '(lambda () (getpoint "\nТочка вставки <Отмена> : "))
                             ) ;_ end of vl-catch-all-apply
                        ) ;_ end of setq
                  ) ;_ end of type
            ) ;_ end of =
         ) ;_ end of and
     (vla-addmtext
       (vla-objectidtoobject
         adoc
         (vla-get-ownerid (setq ent (vlax-ename->vla-object ent)))
         ) ;_ end of vla-ObjectIDToObject
       (vlax-3d-point pt)
       0.
       (strcat "%<\\AcObjProp Object(%<\\_ObjId "
               (vl-princ-to-string (vla-get-objectid ent))
               ">%).Area \\f \"%lu6%qf1\">%"
               ) ;_ end of strcat
       ) ;_ end of vla-addmtext
     ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

[VVA]

+
http://forum.dwg.ru/showthread.php?t=14528

[zenon]

KitoX Toolset !
KitoX Toolset v6 - мощное БЕСПЛАТНОЕ приложение для AutoCAD от www.kitoX.com тута посмотри

[Redya]

Алексей, а можно чтобы значение площади он вставлял в метрах кв., т.е. с коэффициентом 0.000001?

[Кулик Алексей aka kpblc]

Код:

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

(defun c:sq (/ adoc ent pt get-objectid-x86-x64)

  ;;--------------------------------------------------------
  ;; Функция получает строковое представление ObjectID
  ;; вне зависимости от того AutoCAD x86 или x64
  ;; Источник: https://discussion.autodesk.com/forums/message.jspa?messageID=6172961
  ;; http://forum.dwg.ru/showpost.php?p=566244&postcount=8
  ;;--------------------------------------------------------
  (defun get-objectid-x86-x64 (obj / util)
    (setq util (vla-get-utility (vla-get-activedocument (vlax-get-acad-object))))
    (if (= (type obj) 'ename)
      (setq obj (vlax-ename->vla-object obj))
      ) ;_ end of if
    (if (= (type obj) 'vla-object)
      (if (> (vl-string-search "x64" (getvar "platform")) 0)
        (vlax-invoke-method util "GetObjectIdString" obj :vlax-false)
        (rtos (vla-get-objectid obj) 2 0)
        ) ;_ end of if
      ) ;_ end of if
    ) ;_ end of defun

  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-StartUndoMark
  (if
    (and (= (type (setq ent
                         (vl-catch-all-apply
                           '(lambda () (car (entsel "\nУкажите полилинию <Отмена> : ")))
                           ) ;_ end of vl-catch-all-apply
                        ) ;_ end of setq
                  ) ;_ end of type
            'ename
            ) ;_ end of =
         (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
         (/= (logand (cdr (assoc 70 (entget ent))) 129) 0)
         (= (type (setq pt (vl-catch-all-apply
                             '(lambda () (getpoint "\nТочка вставки <Отмена> : "))
                             ) ;_ end of vl-catch-all-apply
                        ) ;_ end of setq
                  ) ;_ end of type
            ) ;_ end of =
         ) ;_ end of and
    (progn
     (vla-addmtext
       (vla-objectidtoobject
         adoc
         (vla-get-ownerid (setq ent (vlax-ename->vla-object ent)))
         ) ;_ end of vla-ObjectIDToObject
       (vlax-3d-point pt)
       0.
       (strcat "%<\\AcObjProp Object(%<\\_ObjId "
               (vl-princ-to-string (get-objectid-x86-x64 ent))
               ">%).Area \\f \"%lu6%qf1%ct8[1e-006]\">%"
               ) ;_ end of strcat
       ) ;_ end of vla-addmtext
     (command "_.updatefield")
    )
     ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

[Помидор]

А можно ли добавить подчеркивание значений?

[Profan]

Код:

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

;************AREA_k.LSP - Вычисление площади контура и простановка значения на плане ******
;                      
;         Разработал  Громов В.В. Март 2006.
;
(defun C:AREAK (/ echo osm slt pl s dn area ptt)
       (setq echo (getvar "CMDECHO"))
       (setvar "CMDECHO" 0)
       (setq osm (getvar "OSMODE"))
       (setq slt (getvar "CLAYER"))
       (vl-cmdf "_AREA" 0 "")
       (if (null prec)
           (progn
           (alert "\n Не задана точность для определения площади!")
           (princ "\n Задайте точность для определения площади.")
           (load "area_prec")
       ))
(while (null pl)
       (setq pl (entsel "\n Выберите замкнутый контур: "))
       (if pl 
       (progn
            (if (= (cdr (assoc 70 (entget (car pl)))) 1)
            (Progn
            (command "_AREA" "_O" pl)
            (setq s (getvar "area"))
            (setq s (/ s 1000000))
            (princ "\n Площадь контура = ")(princ s) (princ " кв.м")
            (cond
            ((<= pre 0) (setq s (rtos s 2 0)))
            ((= pre 1) (setq s (rtos s 2 1)))
            ((>= pre 2) (setq s (rtos s 2 2)))
            ) ;cond
            (if (not da) (setq da "Нет"))
            (initget "Да Нет")
            (princ (strcat "\n Подчеркивать число [Да/Нет] <" da ">: ")) 
            (setq dn (getkword))
            (if (= dn nil) (setq dn da))
            (setq da dn)
            (setvar "OSMODE" 0)
            (if (= dn "Да")
                (progn
                (command "_-LAYER" "_M" "Помещения" "")
                (setq area (strcat "%%U" s "%%U"))
            )) ; progn,if
            (if (= dn "Нет")
                (progn
                (command "_-LAYER" "_M" "Экспликация" "")
                (setq area s)
            )) ; progn,if
            (princ "\n Укажите место размещения текста: ")
            (setq kod40 (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))))
            (if (= kod40 0)
            (command "_TEXT" "0,0" "" "" area "_copybase" "0,0" (entlast) "" "_erase" (entlast) "" "_pasteclip" pause)
            (command "_TEXT" "0,0" "" area "_copybase" "0,0" (entlast) "" "_erase" (entlast) "" "_pasteclip" pause)
            ) ;if
            (princ "\n Площадь контура = ")(princ s) (princ " кв.м")
            ) ;progn
            (progn
            (setq pl nil)
            (princ "\n Это не есть замкнутая полилиния! Попробуйте еще раз.")
            ) ;progn
            ) ;if
        ) ;progn
        (princ "\n Замкнутый контур не выбран! Попробуйте еще раз.")
        ) ;if
) ;while
       (setvar "CMDECHO" echo)
       (setvar "OSMODE" osm)
       (command "_-LAYER" "_S" slt "")
       (princ)
)

Вспомогательная программа:

;*************** area_spec.lsp ******************************************
; Задание точности при определении площади.

Код:

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

(apply '(lambda ()
       (if (null prec) (setq prec "1"))
       (initget 4 "0 1 2")
       (princ (strcat "\n Количество знаков после точки [0/1/2] <" prec ">: "))
       (setq pre (getint))
       (if (= pre nil) (setq pre (atoi prec)))
       (if (> pre 2)
       (progn 
       (setq pre 2)
       (alert " Дико извиняюсь! Ограничимся 2-мя знаками.")
       ))
       (setq prec (itoa pre))
(princ)
)
'()
)

[Помидор]

Неудобно, что каждый раз приходится отвечать на запросы (количество знаков, подчеркивание)

[Profan]

Миллиардам людей удобно, а тебе неудобно. Количество знаков запоминается. А некоторым нужно было именно два варианта: с подчеркиванием и без.

[Помидор]

А нельзя допустим безболезненно удалить пару строчек из кода, чтобы не было вариантов выбора, а осталось "подчеркивать" и "1 знак"?

[IL-14]

Сообщение от Profan ; ; Разработал Громов В.В. Март 2006.

Добрый день! Полезнейшая вещь. А если бы она под числом с площадью еще и длину полилинии выводила - вообще цены б ей не было! )

[Pavel_V]

В Нанокаде не работает

[1958]

Сообщение от IL-14 если бы она под числом с площадью еще и длину полилинии выводила

Мой вариант:

Код:

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

 ;;; Мультиыноска с длиной и площадью линии в поле
;;; http://geodesist.ru/members/1958.30261/
;;; 07 декабря 2024г.
(defun c:mla (/ acsp adoc ent p1 p2 pline txt)
 (vl-load-com)
 (or adoc (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
 (if (and (= (getvar "tilemode") 0) (= (getvar "cvport") 1))
  (setq acsp (vla-get-paperspace adoc))
  (setq acsp (vla-get-modelspace adoc))
 )
 (while (setq pline (vlax-ename->vla-object (car (setq ent (entsel "\nУкажите линию >> \n")))))
  (setq txt (strcat "L = "
                    (rtos (vla-get-length pline) 2 2)
                    " м"
                    "\nS = "
                    (rtos (vla-get-area pline) 2 2)
                    " кв.м"
            )
  )
  (setq p1 (vlax-curve-getClosestPointTo pline (cadr ent))
        p2 (getpoint p1 "\nТочка вставки >> \n")
  )
  (vl-cmdf "_mleader" p1 p2 txt)
  (setq ent (vlax-ename->vla-object (entlast)))
  (vla-put-TextHeight ent 2.00) ; размер шрифта (высота)
  (vla-put-TextJustify ent 1) ;выравнивание текста (1-слева)
  (vla-put-TextLeftAttachmentType ent 4) ;присоединение текста слева
  (vla-put-TextRightAttachmentType ent 4) ;присоединение текста справа
;;;  0 - верх строки 1
;;;  1 - середина строки 1
;;;  2 - низ строки 1
;;;  3 - подчеркивание строки 1
;;;  4 - середина текста
;;;  5 - середина послед.строки
;;;  6 - низ послед.строки
;;;  7 - подчеркивание послед.строки
;;;  8 - подчеркивание всего текста
  (vla-put-DoglegLength ent 0.5) ;величина полки (длина)
;;; (vla-put-TextStyleName ent "ИмяТекстСтиля");изменение текстового стиля
  (vla-regen adoc acactiveviewport)
 )
 (princ)
)

[IL-14]

Сообщение от 1958 Мой вариант:

Спасибо, работает!

Но отдельный кайф был в данных, выводимых обычным текстом в пространстве модели. Тут же на форуме есть классный код, который позволяет выбирать числовые пары, и экспортирует их в 2 столбца в экселе, что позволяет переносить данные по площади/периметру в эксель и там манипулировать ими. Но это детали, мультивыноски можно и разнести ради такого дела.

Не здесь перевод в эксель, на Геодезисте (сорри). Там несколько файлов по маске AcadToExcel0xa.

[IL-14]

Сообщение от 1958 Мой вариант:

Код работает хорошо, но беда с кодировкой кириллицы и результаты выдаются в мм и кв.мм. Если его слегка изменить -->
(setq txt (strcat ""
(rtos (/ (vla-get-length pline) 1000) 2 2)
"m"
"\n"
(rtos (/ (vla-get-area pline) 1000000) 2 2)
""
)

, то метры и квадратные метры, разбивая выноски и мультитекст с выбором по подобию, легко можно забрать в эксель с помощью txt_to_excel.dvb уважаемого VVA и там ими манипулировать по потребностям. Чтоб не запутаться, у длин остается постфикс "m", который легко убирается в экселе.