[Borikv]

Со старых времён есть симпатичный лисп для подсчёта площадей. Проблема, что только для POLYLINE .Как его приспособить и для LWPOLYLINE?

Код:

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

(defun C:WR (/ SS N L H NAME P1 P2 POLY PT)
;Write AREA of Polylines
   (setq *ERROR* STOP)
   (princ "\nSelect Polylines for Area: ")
   (setq SS (ssget)
         N 0
         L (sslength SS)
   )
   (initget 1)
   (setvar "cmdecho" 1)
   (setq H (* 500 (getvar "DimTXT")))
   (if (not (tblsearch "STYLE" "H"))
       (command "style" "h" "standard" "" "1" "" "" "" "")
   )
   (repeat L
      (setq NAME (ssname SS N)
            P1 (cdr (assoc 10 (entget (entnext NAME))))
            P2 (cdr (assoc 10 (entget (entnext (entnext (entnext NAME))))))
            PT (MIDPT P1 P2)
            POLY (list (ssname SS N) P1)
      )
      (command "area" "e" POLY)
      (setq S (getvar "AREA")
            $AREA (rtos (/ S 10000) 2 2)
            N (1+ N)
      )
      (command "text" "style" "h" "c" PT H "0" $AREA)
   )
   (setvar "cmdecho" 1)
   (princ)
)
;
(defun MIDPT (PT1 PT2)
   (mapcar '(lambda (x y) (/ (+ x y) 2)) PT1 PT2)
)
;
(defun STOP (msg)
   (cond
      ((or (eq msg "console break")
           (eq msg "Function cancelled")
           (eq msg "quit / exit abort")
        )
        (terpri)
      )
      (T
          (princ "error: ")
          (princ msg)
      )
   )
   (setq *error* nil)
   (PrinC)
)
;
(C:WR)

Тэги [cоde] опять для меня оставлены на проставление? /kpblc/

[VVA]

Как-то так

Код:

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

(defun C:WR (/ SS N L H NAME P1 P2 POLY PT *ERROR*)
  (defun *ERROR* (msg)
   (cond
      ((or (eq msg "console break")
           (eq msg "Function cancelled")
           (eq msg "quit / exit abort")
        )
        (terpri)
      )
      (T
          (princ "error: ")
          (princ msg)
      )
   )
   (setq *error* nil)
   (PrinC)
)
  (vl-load-com)
;Write AREA of Polylines
   
   (princ "\nSelect Polylines for Area: ")
   (setq SS (ssget '((0 . "*POLYLINE")))
         N 0
         L (sslength SS)
   )
   (initget 1)
   (setvar "cmdecho" 1)
   (setq H (* 500 (getvar "DimTXT")))
   (if (not (tblsearch "STYLE" "H"))
       (command "_-style" "h" "standard" "" "1" "" "" "" "")
   )
   (repeat L
      (setq NAME (ssname SS N)
            POLY (vlax-ename->vla-object NAME)
            P1 (vlax-curve-getPointAtParam POLY 0)
            P2 (if(>(vlax-curve-getEndParam POLY) 1)(vlax-curve-getPointAtParam POLY 2)(vlax-curve-getPointAtParam POLY 1))
            PT (trans (mapcar '(lambda (x y) (* (+ x y) 0.5)) P1 P2) 0 1)
      )
      (setq S (vla-get-area POLY)
            $AREA (rtos (/ S 10000) 2 2)
            N (1+ N)
      )
      (command "_-text" "_style" "h" "_c" PT H "0" $AREA)
   )
   (setvar "cmdecho" 1)
   (princ)
)
;
(C:WR)

[Borikv]

Спасибо, чудно работает.

[Borikv]

Иногда почему-то не срабатывает на Pline. Пишет "Automation Error. Invalid class". Но если просто скопировать этот же контур, то на копии всё срабатыает.

[VVA]

Я с таким встречался, если в сеансе сконвертивать 2d POLYLINE в LWPOLYLINE командами _convert или _convertpoly, то в dxf представлении она становится LWPOLYLINE, а в объектном остается прежней 2d POLYLINE. Отсюда при попытке взять свойсво и выскакивает "Automation Error. Invalid class".
PS Сказанное справедливо и для PLINETYPE = 2
Просто ради подтверждения сказанного, если еще раз встретится такой случай, попробуй просто сохранить чертеж, закрыть и открыть снова. Результат опубликуй здесь