[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 знак"?