改编简单填充面积,期盼复杂填充也能用

wanhongron

;;;△△△单边界填充面积
(defun c:tcmj() (c:hatchb))  ；调用子函数hatchb
(defun c:hatchb (/    es      blay      ed1  ed2
   loops1    bptf      part      et  noe
   plist    ic      bul       nr  ang1
   ang2    obj      *ModelSpace*  *PaperSpace*
   space    cw      errexit   undox  olderr
   oldcmdecho      ss1       lastent  en1
   en2    ss      lwp       list->variantArray
   3dPoint->2dPoint    A2k       ent  i
   ss2    knot-list controlpoint-list  kn
   cn    pos      xv        bot  area
   hst
  )
(setq tc1 (getvar "CLAYER"))
(if (not (tblsearch "LAYER" "填充面积"))
    (command "layer" "m" "填充面积" "c" 2 "" "l" "dashed" "" "lw" 0 "" "")
    (command "layer" "s" "填充面积" "")
)
(command "layer" "s" "填充面积" "")
(setvar "cecolor" "bylayer")
  (setq A2k (>= (substr (getvar "ACADVER") 1 2) "15"))
  (if A2k
    (progn
      (defun list->variantArray (ptsList / arraySpace sArray)
(setq arraySpace
        (vlax-make-safearray
   vlax-vbdouble
   (cons 0 (- (length ptsList) 1))
        )
)
(setq sArray (vlax-safearray-fill arraySpace ptsList))
(vlax-make-variant sArray)
      )
      (defun areaOfObject (en / curve area)
(if en
   (if A2k
     (progn
       (setq curve (vlax-ename->vla-object en))
       (if
  (vl-catch-all-error-p
    (setq
      area
       (vl-catch-all-apply 'vlax-curve-getArea (list curve))
    )
  )
   nil
   area
       )
     )
     (progn
       (command "._area" "_O" en)
       (getvar "area")
     )
   )
)
      )
    )
  )
  (if A2k
    (defun 3dPoint->2dPoint (3dpt)
      (list (float (car 3dpt)) (float (cadr 3dpt)))
    )
(setvar "CLAYER" tc1)
  )
  (defun errexit (s)
    (princ "\nError:  ")
    (princ s)
    (restore)
  )
  (defun undox ()
    (command "._ucs" "_p")
    (command "._undo" "_E")
    (setvar "cmdecho" oldcmdecho)
    (setq *error* olderr)
    (princ)
  )
  (setq olderr *error*
restore undox
*error* errexit
  )
  (setq oldcmdecho (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (command "._UNDO" "_BE")
  (if A2k
    (progn
      (vl-load-com)
      (setq *ModelSpace* (vla-get-ModelSpace
      (vla-get-ActiveDocument (vlax-get-acad-object))
    )
     *PaperSpace* (vla-get-PaperSpace
      (vla-get-ActiveDocument (vlax-get-acad-object))
    )
      )
    )
  )
     ; For testing purpose
     ; (setq A2k nil)
  (if (/= (setq ss2 (ssget '((0 . "HATCH")))) nil)
    (progn
      (setq i 0)
      (setq area 0)
      (setq bMoreLoops nil)
      (while (setq ent (ssname ss2 i))
(setq ed1 (entget ent))
(if (not (equal (assoc 210 ed1) '(210 0.0 0.0 1.0)))
   (princ "\nHatch not in WCS!")
)
(setq xv (cdr (assoc 210 ed1)))
(command "._ucs" "_w")
(setq loops1 (cdr (assoc 91 ed1)))
     ; number of boundary paths (loops)
(if (and A2k (= (strcase (cdr (assoc 410 ed1))) "MODEL"))
   (setq space *ModelSpace*)
   (setq space *PaperSpace*)
)
(repeat loops1
   (setq ed1 (member (assoc 92 ed1) ed1))
   (setq bptf (cdr (car ed1))) ; boundary path type flag
   (setq ic (cdr (assoc 73 ed1))) ; is closed
   (setq noe (cdr (assoc 93 ed1))) ; number of edges
   (setq bot (cdr (assoc 92 ed1))) ; boundary type
   (setq hst (cdr (assoc 75 ed1))) ; hatch style
   (setq ed1 (member (assoc 72 ed1) ed1))
   (setq bul (cdr (car ed1))) ; bulge
   (setq plist nil)
   (setq blist nil)
   (cond
     ((> (boole 1 bptf 2) 0) ; polyline
      (repeat noe
        (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
        (setq plist (append plist (list (cdr (assoc 10 ed1)))))
        (setq blist (append blist
       (if (> bul 0)
         (list (cdr (assoc 42 ed1)))
         nil
       )
      )
        )
      )
      (if A2k
        (progn
   (setq polypoints
   (apply 'append
          (mapcar '3dPoint->2dPoint plist)
   )
   )
   (setq VLADataPts (list->variantArray polypoints))
   (setq
     obj (vla-addLightweightPolyline space VLADataPts)
   )
   (setq nr 0)
   (repeat (length blist)
     (if (/= (nth nr blist) 0)
       (vla-setBulge obj nr (nth nr blist))
     )
     (setq nr (1+ nr))
   )
   (if (= ic 1)
     (vla-put-closed obj T)
   )
        )
        (progn
   (if (= ic 1)
     (entmake '((0 . "POLYLINE") (66 . 1) (70 . 1)))
     (entmake '((0 . "POLYLINE") (66 . 1)))
   )
   (setq nr 0)
   (repeat (length plist)
     (if (= bul 0)
       (entmake (list (cons 0 "VERTEX")
        (cons 10 (nth nr plist))
         )
       )
       (entmake (list (cons 0 "VERTEX")
        (cons 10 (nth nr plist))
        (cons 42 (nth nr blist))
         )
       )
     )
     (setq nr (1+ nr))
   )
   (entmake '((0 . "SEQEND")))
        )
      )
     )
     (t    ; not polyline
      (setq lastent (entlast))
      (setq lwp T)
      (repeat noe
        (setq et (cdr (assoc 72 ed1)))
        (cond
   ((= et 1)  ; line
    (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
    (if A2k
      (vla-AddLine
        space
        (vlax-3d-point (cdr (assoc 10 ed1)))
        (vlax-3d-point (cdr (assoc 11 ed1)))
      )
      (entmake
        (list
   (cons 0 "LINE")
   (list 10
         (cadr (assoc 10 ed1))
         (caddr (assoc 10 ed1))
         0
   )
   (list 11
         (cadr (assoc 11 ed1))
         (caddr (assoc 11 ed1))
         0
   )
        )
      )
    )
    (setq ed1 (cddr ed1))
   )
   ((= et 2)  ; circular arc
    (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
    (setq ang1 (cdr (assoc 50 ed1)))
    (setq ang2 (cdr (assoc 51 ed1)))
    (setq cw (cdr (assoc 73 ed1)))
    (if (equal ang2 6.28319 0.00001)
      (progn
        (if A2k
   (vla-AddCircle
     space
     (vlax-3d-point (cdr (assoc 10 ed1)))
     (cdr (assoc 40 ed1))
   )
   (entmake (list (cons 0 "CIRCLE")
           (assoc 10 ed1)
           (assoc 40 ed1)
     )
   )
        )
        (setq lwp nil)
      )
      (if A2k
        (vla-AddArc
   space
   (vlax-3d-point (cdr (assoc 10 ed1)))
   (cdr (assoc 40 ed1))
   (if (= cw 0)
     (- 0 ang2)
     ang1
   )
   (if (= cw 0)
     (- 0 ang1)
     ang2
   )
        )
        (entmake (list (cons 0 "ARC")
         (assoc 10 ed1)
         (assoc 40 ed1)
         (cons 50
        (if (= cw 0)
          (- 0 ang2)
          ang1
        )
         )
         (cons 51
        (if (= cw 0)
          (- 0 ang1)
          ang2
        )
         )
          )
        )
      )
    )
    (setq ed1 (cddddr ed1))
   )
   ((= et 3)  ; elliptic arc
    (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
    (setq ang1 (cdr (assoc 50 ed1)))
    (setq ang2 (cdr (assoc 51 ed1)))
    (setq cw (cdr (assoc 73 ed1)))
    (if A2k
      (progn
        (setq obj (vla-AddEllipse
      space
      (vlax-3d-point (cdr (assoc 10 ed1)))
      (vlax-3d-point (cdr (assoc 11 ed1)))
      (cdr (assoc 40 ed1))
    )
        )
        (vla-put-startangle
   obj
   (if (= cw 0)
     (- 0 ang2)
     ang1
   )
        )
        (vla-put-endangle
   obj
   (if (= cw 0)
     (- 0 ang1)
     ang2
   )
        )
      )
      (princ "\nElliptic arc not supported!")
    )
    (setq lwp nil)
   )
   ((= et 4)  ; spline
    (setq ed1 (member (assoc 94 (cdr ed1)) ed1))
    (setq knot-list nil)
    (setq controlpoint-list nil)
    (setq kn (cdr (assoc 95 ed1)))
    (setq cn (cdr (assoc 96 ed1)))
    (setq pos (vl-position (assoc 40 ed1) ed1))
    (repeat kn
      (setq
        knot-list (cons (cons 40 (cdr (nth pos ed1)))
          knot-list
    )
      )
      (setq pos (1+ pos))
    )
    (setq pos (vl-position (assoc 10 ed1) ed1))
    (repeat cn
      (setq controlpoint-list
      (cons
        (cons 10 (cdr (nth pos ed1)))
        controlpoint-list
      )
      )
      (setq pos (1+ pos))
    )
    (setq knot-list (reverse knot-list))
    (setq controlpoint-list (reverse controlpoint-list))
    (entmake (append
        (list '(0 . "SPLINE"))
        (list (cons 100 "AcDbEntity"))
        (list (cons 100 "AcDbSpline"))
        (list (cons 70
      (+ 1
         8
         (* 2 (cdr (assoc 74 ed1)))
         (* 4 (cdr (assoc 73 ed1)))
      )
       )
        )
        (list (cons 71 (cdr (assoc 94 ed1))))
        (list (cons 72 kn))
        (list (cons 73 cn))
        knot-list
        controlpoint-list
      )
    )
    (setq ed1 (member (assoc 10 ed1) ed1))
    (setq lwp nil)
   )
        )   ; end cond
      )    ; end repeat noe
      (if lwp
        (progn
   (setq en1 (entnext lastent))
   (setq ss (ssadd))
   (ssadd en1 ss)
   (while (setq en2 (entnext en1))
     (ssadd en2 ss)
     (setq en1 en2)
   )
   (if (= (getvar "peditaccept") 1)
     (command "_.pedit" (entlast) "_J" ss "" "")
     (command "_.pedit" (entlast) "_Y" "_J" ss "" "")
   )
        )
      )
     )    ; end t
   )    ; end cond
)    ; end repeat loops1
(if (= loops1 1)
   (setq area (+ area (areaOfObject (entlast))))
   (setq bMoreLoops T)
)
(setq i (1+ i))
      )
    )
  )
  (if (and area (not bMoreLoops))
    (progn
      (princ "\n总面积= ")
      (princ (/ area 1000000))
    )
  )
  (restore)
  (princ)
)

wanhongron

单条边界能算，两条边界不能算，见图，左边圆能，右边圆环不能。

jack11280

試試這個應該是你須要的

jack11280

試試這個