[编程交流] 切割面积

;;;DIVAREA.LSP  Land division utility
;;;  Suppose that you have to split a big part into 2, 3, 4 (or even 5.014!)
;;;  or you want to cut a part of 2345 m2 out of the big one.
;;;
;;;  All you need is a CLOSED LWPOLYLINE enclosing the big part.
;;;
;;;  Load the utility, after placing it into an appropriate folder,
;;;  let's say \Program Files\Acad2000\Support, invoke "APPLOAD" command
;;;  or invoke (LOAD"DIVAREA") and run it by typing DIVAREA.
;;;
;;;  Answer the few questions you will be asked and REMEMBER:
;;;
;;;  When you are prompted to indicate the two points of
;;;  the approximate division line, please bear in mind that
;;;
;;;     1. This DIVISION LINE will be rotated (or be offseted) and
;;;  neither of its endpoints should reside outside of the boundary,
;;;  (although it should have been easy to overcome this bug),
;;;  so pick points as FAR OUT from the boundary as possible,
;;;  not exceeding, of course, your current visibe area.
;;;  As for the FIXED POINT, in case you prefer "F"
;;;  rather than "C" as an answer in the previous question, it has to
;;;  reside on the lwpoly or outside of it, never inside.
;;;
;;;     2. When indicating point into the part which will obtain the desired
;;;  area, you have to indicate INTO it and AS FAR from division line as
;;;  possible, so this point will not be outside of the desired part
;;;  while the division line is moving into it.
;;;
;;;     3. Finally, you have to indicate exactly by the same way,
;;;  FAR FROM DIVISION line and INTO the remaining piece.
;;;  If you prefer more precision you can decrease local vars step2
;;;  and step1 accordingly.
;;;
;;;******************UTILITY STARTS HERE*******************************
(defun prerr (s)
(if (/= s "Function cancelled")
    (princ (strcat "\nError: " s))
);endif
(setq *error* olderr)
(princ)
);close defun
(Defun C:DIVAREA(/ osm strpf strdc ex arxset arx arxon k scl ok
                  d p1 p2 pts ptb deln ar par tem
                  stp stp1 stp2               
               )
(setq olderr *error*
      *error* prerr)
(setq osm(getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setq ex 0
      stp  0.01
      stp1 0.005
      stp2 0.0005
)
(setq arxset (entsel "\nSelect closed LWPOLY to divide: ")
      arx    (entget(car arxset))
      arxon  (cdr (assoc -1 arx))
)
(if (not(and(equal (cdr(assoc 0 arx)) "LWPOLYLINE") (= (cdr(assoc 70 arx)) 1)))
    (progn
          (princ "\nSORRY, ONLY CLOSED LWPOLYLINES ALLOWED...")
          (setq ex 1)
    )
)
(if (= ex 0)
    (progn
      (command "_undo" "m") ;if something goes bad, you may return here
      (command "_layer" "m" "Area_Division" "")
      (command "_area" "e" arxon)
      (setq ar(getvar "area"))
      (initget "Divide Cut")
      (setq strdc(getkword "\nDIVIDE by number or CUT a part ? (D/C) :"))
      (if (= strdc "Divide")
          (progn
                (setq k  (getreal "\nEnter number to divide the whole part by : "))
                (setq tem(/ ar k))
          )
      )
      (if (= strdc "Cut")
          (setq tem (getreal "\nEnter area to cut from the whole part (m2) : "))
      )
      (initget "Parallel Fixed")
      (setq strpf(getkword "\nPARALLEL to a direction or FIXED side? (P/F) :"))
      (if (= strpf "Fixed")
          (fixpt)
      )
      (if (= strpf "Parallel")
          (parpt)
      )
      (ready)
    )
    (ready)
)
)
;******************************************************************************
(defun fixpt ()
(setvar "osmode" osm)
(setq scl    0.05
      p1     (getpoint "\nPick fixed point of the division line : ")
      p2     (getpoint "\nPick second point of division line: ")
)
(setvar "osmode" 0)
(command "_line" p1 p2 "")
(setq deln (entlast))
(setq pts (getpoint "\nPick any point into FIRST piece, FAR from division line: "))
(setq ptb (getpoint "\nPick any point into the REST of the piece, FAR from division line: "))
(setvar "blipmode" 0)
(princ "\nPlease wait...")
(command "_boundary" pts "")
(command "_area" "e" "l")
(setq par(getvar "area"))
(setq ok -1)
(if (< par tem)
 (progn
       (while (< par tem)
        (entdel (entlast))
        (if (< (- tem par) 50)(setq scl stp))
        (if (< (- tem par) 10)(setq scl stp2))
        (command "_rotate" deln "" p1 (* scl ok))
        (command "_boundary" pts "")
        (command "_area" "e" "l")
        (if (< (getvar "area") par)
            (setq ok(* ok -1))
        )
        (setq par(getvar "area"))
       );endwhile
       (entdel deln)
)
 (progn
       (while (> par tem)
        (entdel (entlast))
        (if (< (- par tem) 50)(setq scl stp))
        (if (< (- par tem) 10)(setq scl stp2))
        (command "_rotate" deln "" p1 (* scl ok))
        (command "_boundary" pts "")
        (command "_area" "e" "l")
        (if (> (getvar "area") par)
            (setq ok(* ok -1))
        )
        (setq par(getvar "area"))
       );endwhile
       (entdel deln)
)
)
(command "_change" "l" "" "p" "c" "green" "")
(command "_boundary" ptb "")
(command "_change" "l" "" "p" "c" "red" "")
(ready)
)
;******************************************************************************
(defun parpt ()
(setvar "osmode" osm)
(setq scl    0.25
      p1     (getpoint "\nPick one point of division line (far from lwpoly) : ")
      p2     (getpoint "\nPick other point of division line (far from lwpoly) : ")
)
(setvar "osmode" 0)
(command "_line" p1 p2 "")
(setq deln(entlast))
(setq pts (getpoint "\nPick any point into FIRST piece, FAR from division line: "))
(setq ptb (getpoint "\nPick any point into the REST of the piece, FAR from division line: "))
(setvar "blipmode" 0)
(princ "\nPlease wait...")
(command "_boundary" pts "")
(command "_area" "e" "l")
(setq par(getvar "area"))
(if (< par tem)
 (progn
       (while (< par tem)
        (entdel (entlast))
        (if (< (- tem par) 50)(setq scl stp1))
        (if (< (- tem par) 10)(setq scl stp2))
        (command "_offset" scl deln ptb "")
        (entdel deln)
        (setq deln(entlast))
        (command "_boundary" pts "")
        (command "_area" "e" "l")
        (setq par(getvar "area"))
       )
       (entdel deln)
 )
 (progn
       (while (> par tem)
        (entdel (entlast))
        (if (< (- par tem) 50)(setq scl stp1))
        (if (< (- par tem) 10)(setq scl stp2))
        (command "_offset" scl deln pts "")
        (entdel deln)
        (setq deln(entlast))
        (command "_boundary" pts "")
        (command "_area" "e" "l")
        (setq par(getvar "area"))
       )
       (entdel deln)
 )
)
(command "_change" "l" "" "p" "c" "green" "")
(command "_boundary" ptb "")
(command "_change" "l" "" "p" "c" "red" "")
)
;******************************************************************************
(defun ready ()
 (princ scl)
 (princ "\nActual : ")
 (princ par)
 (princ "\nMust be: ")
 (princ tem)
(setq *error* olderr)
(setvar "osmode" osm)
(setvar "cmdecho" 1)
(setvar "blipmode" 1)
(princ "\nThanks...")
(princ)
);close defun

;;;=======================================================
;;;=======================================================
;;;
;;;  FUNCTION: Area Division (AreaDiv.lsp)
;;;  Calculates the area of a partitioned region.
;;;
;;;  AUTHOR
;;;  Copyright © 2009 Lee McDonnell
;;;    (contact ~ Lee Mac, CADTutor.net)
;;;
;;;  VERSION
;;;  1.0  ~  23.03.2009
;;;
;;;=======================================================
;;;=======================================================
(defun c:ADiv  (/ *error* vlst ovar spc cEnt vpt cCur
         cAng clen grlist arpt spt pt1 pt2 iLin
         iArr iLst ptLst plst stpar vpts aPly)
 
 (vl-load-com)
 (defun *error*  (msg)
   (grtext) (redraw)
   (if    ovar (mapcar 'setvar vlst ovar))
   (if    (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\n<!> Error: " (strcase msg) " <!>")))
   (princ))
 (setq    vlst '("CMDECHO" "OSMODE")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar vlst '(0 0))
 (setq    spc (vla-get-ModelSpace
         (vla-get-ActiveDocument
       (vlax-get-Acad-Object))))
 (if (and (setq cEnt (entsel "\nSelect Edge for Segregation: "))
      (eq "LWPOLYLINE" (cdadr (entget (car cEnt)))))        
   (progn
     (setq vpt (osnap (cadr cEnt) "_nea")
       cCur (vlax-ename->vla-object (car cEnt))
       cAng (angle    '(0 0 0) (vlax-curve-getFirstDeriv cCur
                  (vlax-curve-getParamAtPoint cCur vpt))))
     (setq clen (distance (vlax-curve-getPointatParam cCur
                (fix (vlax-curve-getParamAtPoint cCur vpt)))
              (vlax-curve-getPointatParam cCur
                (1+ (fix (vlax-curve-getParamAtPoint cCur vpt))))))
     (grtext -1 "Select Area Segregation...")
     (while (= 5 (car (setq grlist (grread t 1))))
   (redraw)
   (if (= 'list (type (setq arpt (cadr grlist))))
     (progn
       (setq spt (vlax-curve-getClosestPointto cCur arpt)
         pt1 (polar spt cAng (/ clen 3.0))
         pt2 (polar spt cAng (/ clen -3.0)))
       (grdraw pt1 pt2 3))))
     (setq iLin (vla-Addline spc (vlax-3D-point spt)
          (vlax-3D-point (polar spt cAng clen)))
       iArr (vlax-variant-value
          (vla-IntersectWith iLin cCur acExtendThisEntity)))
     (if (> (vlax-safearray-get-u-bound iArr 1) 0)
   (progn
     (setq iLst (vlax-safearray->list iArr))
     (while (not (zerop (length iLst)))
       (setq ptLst    (cons (list (car iLst) (cadr iLst) (caddr iLst)) ptLst)
         iLst    (cdddr iLst)))
     (and (vla-delete iLin) (setq iLin nil))
     (if (> (length ptlst) 1)
       (progn
         (setq plst  (vl-sort (list (vlax-curve-getParamAtPoint cCur (car ptLst))
               (vlax-curve-getParamAtPoint cCur (cadr ptLst))) '<)
           stpar (1+ (fix (car plst))))
         (while (< stpar (cadr plst))
       (setq plst (append plst (list stpar))
             stpar (1+ stpar)))
         (setq plst (vl-sort plst '<)
           vpts (mapcar '(lambda (p) (vlax-curve-getPointatParam cCur p)) plst))
         (command "_pline") (foreach x vpts (command x)) (command "_C")
         (vla-put-color (setq aPly (vlax-ename->vla-object (entlast))) acRed)
         (princ (strcat "\n<<<  Area of Enclosed Region: " (rtos (vla-get-Area aPly)) " >>>")))
       (princ "\n<!> Selected Segregation not Closed <!>")))
   (princ "\n<!> Area Not Segregated Properly <!>")))
   (princ "\n<!> Nothing Selected or this isn't an LWPLINE <!>"))
 (mapcar 'setvar vlst ovar)
 (grtext) (redraw)
 (princ))
(princ "\n** AreaDiv.lsp Successfully Loaded - type "ADiv" to invoke **") (princ)