[编程交流] 实时矩形区域

; needs front end what to draw c - p - r - T
; this is generic code may not work on some objects
(if (=  obarea nil)(setq obarea 0.0))
(setq obj (vlax-ename->vla-object (entlast)))
(setq obarea (+ (vla-get-area obj) obarea))
(Alert (strcat "Total Area is " (rtos obarea 2 3)))

;;---------------------=={ Total Area }==---------------------;;
;;                                                            ;;
;;  Displays the total area of selected objects at the        ;;
;;  command line.                                             ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2010 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
(defun c:tArea nil
 ;; © Lee Mac 2010
 (
   (lambda ( SelSet Total i / entity )
     (if SelSet
       (princ
         (strcat "\nTotal Area: "
           (rtos
             (while (setq entity (ssname SelSet (setq i (1+ i))))
               (setq Total
                 (+ (vlax-curve-getArea entity) Total)
               )
             )
           )
         )
       )
     )
   )
   (ssget
     (list (cons 0 "CIRCLE,ELLIPSE,*POLYLINE,SPLINE")
       (cons -4 "<NOT")
         (cons -4 "<AND")
           (cons 0 "POLYLINE")
           (cons -4 "<OR")
             (cons -4 "&=") (cons 70 16)
             (cons -4 "&=") (cons 70 64)
           (cons -4 "OR>")
         (cons -4 "AND>")
       (cons -4 "NOT>")
     )
   )
   0.0 -1
 )
 (princ)
)

([color=BLUE]defun[/color] c:recarea ( [color=BLUE]/[/color] are fun ocs pt1 pt2 tot )
   ([color=BLUE]setq[/color] ocs ([color=BLUE]trans[/color] '(0 0 1) 1 0 [color=BLUE]t[/color])
         fun ([color=BLUE]if[/color] ([color=BLUE]zerop[/color] ([color=BLUE]getvar[/color] 'worlducs)) [color=BLUE]getpoint[/color] [color=BLUE]getcorner[/color])
         tot 0.0
   )
   ([color=BLUE]while[/color]
       ([color=BLUE]and[/color]
           ([color=BLUE]setq[/color] pt1 ([color=BLUE]getpoint[/color] [color=MAROON]"\nSpecify first point <exit>: "[/color]))
           ([color=BLUE]setq[/color] pt2 (fun pt1 [color=MAROON]"\rSpecify opposite corner <exit>: "[/color]))
       )
       ([color=BLUE]entmake[/color]
           ([color=BLUE]list[/color]
              '(000 . [color=MAROON]"LWPOLYLINE"[/color])
              '(100 . [color=MAROON]"AcDbEntity"[/color])
              '(100 . [color=MAROON]"AcDbPolyline"[/color])
              '(090 . 4)
              '(070 . 1)
               ([color=BLUE]cons[/color] 038 ([color=BLUE]caddr[/color] ([color=BLUE]trans[/color] pt1 1 ocs)))
               ([color=BLUE]cons[/color] 010 ([color=BLUE]trans[/color] pt1 1 ocs))
               ([color=BLUE]cons[/color] 010 ([color=BLUE]trans[/color] ([color=BLUE]list[/color] ([color=BLUE]car[/color] pt2) ([color=BLUE]cadr[/color] pt1)) 1 ocs))
               ([color=BLUE]cons[/color] 010 ([color=BLUE]trans[/color] pt2 1 ocs))
               ([color=BLUE]cons[/color] 010 ([color=BLUE]trans[/color] ([color=BLUE]list[/color] ([color=BLUE]car[/color] pt1) ([color=BLUE]cadr[/color] pt2)) 1 ocs))
               ([color=BLUE]cons[/color] 210 ocs)
           )
       )
       ([color=BLUE]setq[/color] are ([color=BLUE]apply[/color] '[color=BLUE]*[/color] ([color=BLUE]mapcar[/color] '[color=BLUE]abs[/color] ([color=BLUE]mapcar[/color] '[color=BLUE]-[/color] pt1 pt2 '(0 0))))
             tot ([color=BLUE]+[/color] tot are)
       )
       ([color=BLUE]princ[/color] ([color=BLUE]strcat[/color] [color=MAROON]"\nArea: "[/color] ([color=BLUE]rtos[/color] are) [color=MAROON]" | Total: "[/color] ([color=BLUE]rtos[/color] tot)))
   )
   ([color=BLUE]princ[/color])
)