切割面积

Lee Mac · 发表于 2022-7-5 18:35:47

之后检索该区域…-你用它来划分你的主要区域，然后显示该区域。

Lee Mac · 发表于 2022-7-5 18:39:40

有关详细信息，请参阅所附视频。。。
AreaDiv。拉链

Oliver · 发表于 2022-7-5 18:41:28

好啊我们现在想要的是一个目标区域。。f面积为1000平方米。。只需要350平方米。。如视频所示，你可以把它放在任何你想要的地方。。

Lee Mac · 发表于 2022-7-5 18:46:14

好的，这更好：

copy


;;;=======================================================
;;;=======================================================
;;;
;;;  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 doc spc cEnt ParamLst vpt
         cCur cAng clen grlist arpt spt pt1 pt2 iLin
         iArr iLst ptLst plst stpar vpts aPly int1 int2
         2vpts bPly ObjArr Regs aReg bReg tCenLst tCen
         tht Area_text)
 
 (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    doc (vla-get-ActiveDocument
         (vlax-get-Acad-Object))
   
   spc (if (zerop (vla-get-activespace doc))
         (if (= (vla-get-mspace doc) :vlax-true)
       (vla-get-modelspace doc)
       (vla-get-paperspace doc))
         (vla-get-modelspace doc)))  
 (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))))))
     (setq ParamLst (mapcar '(lambda (cVert) (vlax-curve-getParamAtPoint cCur cVert))
                (mapcar 'cdr (vl-remove-if-not
                       '(lambda (x) (= 10 (car x)))
                       (entget (car cEnt))))))
     
     (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 (setq int1 (vlax-curve-getParamAtPoint cCur (car ptLst)))
               (setq int2 (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 (apply 'append
               (mapcar '(lambda (x) (list (car x) (cadr x)))
                   (mapcar '(lambda (p)
                          (vlax-curve-getPointatParam cCur p)) plst))))
         (setq vpts (vlax-make-variant
              (vlax-safearray-fill
                (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length vpts)))) vpts)))
         (setq aPly (vla-AddLightWeightPolyline spc vpts))
         (vla-put-closed aPly :vlax-true)
         (setq ParamLst (vl-sort
                  (append
                (vl-remove-if
                  '(lambda (param) (member param plst)) ParamLst)
                (list int1 int2)) '<)
           2vpts (apply 'append
                (mapcar '(lambda (x) (list (car x) (cadr x)))
                 (mapcar '(lambda (p)
                        (vlax-curve-getPointatParam cCur p)) ParamLst))))
         (setq 2vpts (vlax-make-variant
               (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length 2vpts)))) 2vpts)))
         (setq bPly (vla-AddLightWeightPolyline spc 2vpts))
         (vla-put-Closed bPly :vlax-true)          
         (setq ObjArr (vlax-safearray-fill
                (vlax-make-safearray vlax-vbobject '(0 . 1)) (list aPly bPly))
           Regs (vlax-safearray->list
              (vlax-variant-value
                (vla-AddRegion spc ObjArr)))
           aReg (car Regs) bReg (cadr Regs))
         (mapcar 'vla-delete (list aPly bPly))
         (vla-put-color aReg acRed)
         (vla-put-color bReg acGreen)
         (setq tCenLst (mapcar '(lambda (c) (vlax-safearray->list
                       (vlax-variant-value
                         (vla-get-Centroid c)))) (list aReg bReg)))
         (setq tCen (mapcar 'vlax-3d-point
                (mapcar 'append tCenLst (list (list 0.0) (list 0.0))))
           tht (getvar "TEXTSIZE")
           Area_text (mapcar 'vla-AddText (list spc spc)
                     (mapcar '(lambda (str) (strcat "Area: " (rtos str)))
                         (mapcar 'vla-get-Area (list aReg bReg)))
                     tCen (list tht tht)))
         (mapcar 'vla-put-color Area_text (list acRed acGreen))
         
         (princ (strcat "\n<<<  Red Area: " (rtos (vla-get-Area aReg))
                ", Green Area: " (rtos (vla-get-Area bReg)) " >>>")))
       
       (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)

Oliver · 发表于 2022-7-5 18:47:49

很好。。但我的观点不是我的朋友。。。
我这里有一个惯例。。尝试根据需要进行更新。。

copy

(defun ang_between (p10 p11 p20 p21 / px p1 p2 l_pt l_d p ang)
   (setq px (inters p10 p11 p20 p21 nil))
   (cond
       (px
           (if (> (distance px p10) (distance px p11)) (setq p1 p10) (setq p1 p11))
           (if (> (distance px p20) (distance px p21)) (setq p2 p20) (setq p2 p21))
           (setq
               l_pt (list px p1 p2)
               l_d (mapcar 'distance l_pt (append (cdr l_pt) (list (car l_pt))))
               p (/ (apply '+ l_d) 2.0)
               ang (* (atan (sqrt (/ (* (- p (car l_d)) (- p (caddr l_d))) (* p (- p (cadr l_d)))))) 2.0)
           )
       )
       (T
           nil
       )
   )
)
(defun c:cu ( / pt1 pt2 pt3 pt4 S1 ang1 ang2 x1 x2 ptx1 ptx2)
 (setq pt1 (getpoint "\nFirst point of baseline: "))
 (setq pt2 (getpoint pt1 "\nSecond point of baseline: "))
 (setq pt3 (getpoint pt1 "\nPoint of first adjacent side: "))
 (setq pt4 (getpoint pt2 "\nPoint of second adjacent side: "))
 (setq S1 (getreal "\nWanted area: "))
 (setq ang1 (ang_between pt1 pt2 pt1 pt3))
 (setq ang2 (ang_between pt2 pt1 pt2 pt4))
 (setq ang1 (- pi ang1) ang2 (- pi ang2))
 (setq x1
   (*
     (/
       (* (distance pt1 pt2) (sin ang1))
       (sin (+ ang1 ang2))
     )
     (1-
       (+ ;or can be "-"
         (sqrt
           (1+
             (/
               (* 2.0 S1 (sin (+ ang1 ang2)))
               (* (distance pt1 pt2) (distance pt1 pt2) (sin ang1) (sin ang2))
             )
           )
         )
       )
     )
   )
 )
 (setq x2 (/ (* x1 (sin ang2)) (sin ang1)))
 (setq ptx1 (polar pt1 (angle pt1 pt3) x2))
 (setq ptx2 (polar pt2 (angle pt2 pt4) x1))
 (command "_.line" "_none" ptx1 "_none" ptx2 "")
)

干杯

奥利弗

Lee Mac · 发表于 2022-7-5 18:50:31

你在说什么？

我对原来的帖子还不满意吗？

CarlB · 发表于 2022-7-5 18:54:25

李-
你的习惯对我不起作用，所以我不确定。。。
但是从之前的帖子中，你似乎忽略了用户需要输入一个目标区域——例如，最终的隔离区域需要是“1000平方英尺”——并且例程会计算出在何处放置分界线，以创建具有该区域的分区。
可能需要一些迭代。

BIGAL · 发表于 2022-7-5 18:58:10

该问题的解决方案是Civil 3d或其他民用软件（如Civilcad）中地块选项的一部分。

你有多种选择来创建地块、平行线、旋转方向、临街距离等，这些AK用于所需区域，如上所述，迭代以找到解决方案。有非常快的使用。

因此，lisp程序需要将行答案迭代到一个容差。如果公制单位为1mm。

Lee Mac · 发表于 2022-7-5 19:00:26

哦，一定是错过了那篇帖子/听不懂。

不过我只是想升级我的另一个LISP

copy


;;;=======================================================
;;;=======================================================
;;;
;;;  FUNCTION: Area Division (AreaDiv.lsp)
;;;  Calculates the area of a partitioned region and
;;;  displays the result as text at the centroid of the
;;;  partitioned area.
;;;
;;;  AUTHOR
;;;  Copyright © 2009 Lee McDonnell
;;;  (contact Lee Mac, CADTutor.net)
;;;
;;;  VERSION
;;;  1.0  ~  23.03.2009
;;;
;;;=======================================================
;;;=======================================================
(defun c:ADiv  (/ *error* vlst ovar doc spc cEnt ParamLst vpt
         cCur cAng clen grlist arpt spt pt1 pt2 iLin
         iArr iLst ptLst plst stpar vpts aPly int1 int2
         2vpts bPly ObjArr Regs aReg bReg tCenLst tCen
         tht Area_text movp CurDel Cenpt Thtov VecCol)
 ; ===== Adjustments ======
 (setq CurDel T)   ;;  Delete Original Region
 (setq Cenpt nil)  ;;  Points at Region Centroids
 (setq Thtov 0.0)  ;;  Text Height Override
 (setq VecCol 3)   ;;  Partition Tool Colour (0-255)
 ; ========================
 
 (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" "PDMODE")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar vlst '(0 0))
 (setq    doc (vla-get-ActiveDocument
         (vlax-get-Acad-Object))
   
   spc (if (zerop (vla-get-activespace doc))
         (if (= (vla-get-mspace doc) :vlax-true)
       (vla-get-modelspace doc)
       (vla-get-paperspace doc))
         (vla-get-modelspace doc)))  
 (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)))
       clen (distance (vlax-curve-getPointatParam cCur
                (fix (vlax-curve-getParamAtPoint cCur vpt)))
              (vlax-curve-getPointatParam cCur
                (1+ (fix (vlax-curve-getParamAtPoint cCur vpt)))))
       ParamLst (mapcar '(lambda (cVert) (vlax-curve-getParamAtPoint cCur cVert))
                (mapcar 'cdr (vl-remove-if-not
                       '(lambda (x) (= 10 (car x)))
                       (entget (car cEnt))))))
     (or (and (<= 0 VecCol 255) (setq vcol VecCol)) (setq vcol 3))
     (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 vcol))))
     
     (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 (setq int1 (vlax-curve-getParamAtPoint cCur (car ptLst)))
               (setq int2 (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 (apply 'append
               (mapcar '(lambda (x) (list (car x) (cadr x)))
                   (mapcar '(lambda (p)
                          (vlax-curve-getPointatParam cCur p)) plst)))
           vpts (vlax-make-variant
              (vlax-safearray-fill
                (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length vpts)))) vpts))
           aPly (vla-AddLightWeightPolyline spc vpts))
         (vla-put-closed aPly :vlax-true)
         (setq ParamLst (vl-sort
                  (append
                (vl-remove-if
                  '(lambda (param) (member param plst)) ParamLst)
                (list int1 int2)) '<)
           2vpts (apply 'append
                (mapcar '(lambda (x) (list (car x) (cadr x)))
                 (mapcar '(lambda (p)
                        (vlax-curve-getPointatParam cCur p)) ParamLst)))
           2vpts (vlax-make-variant
               (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length 2vpts)))) 2vpts))
           bPly (vla-AddLightWeightPolyline spc 2vpts))
         (vla-put-Closed bPly :vlax-true)          
         (setq ObjArr (vlax-safearray-fill
                (vlax-make-safearray vlax-vbobject '(0 . 1)) (list aPly bPly))
           Regs (vlax-safearray->list
              (vlax-variant-value
                (vla-AddRegion spc ObjArr)))
           aReg (car Regs) bReg (cadr Regs))
         (mapcar 'vla-delete (list aPly bPly))
         (vla-put-color aReg acRed)
         (vla-put-color bReg acGreen)
         (setq tCenLst (mapcar '(lambda (c) (vlax-safearray->list
                       (vlax-variant-value
                         (vla-get-Centroid c)))) (list aReg bReg))
           tBox (mapcar 'textbox
                (mapcar '(lambda (str) (list (cons 1 (strcat "Area: " (rtos Str)))))
                    (setq AreaLst (mapcar 'vla-get-Area (list aReg bReg)))))
           movp (mapcar 'vlax-3d-point
                (mapcar '(lambda (x)
                       (mapcar '* (mapcar '/ (mapcar '+ (car x) (cadr x))
                           '(2.0 2.0 1.0)) '(-1.0 -1.0 1.0))) tBox))
           tCen (mapcar 'vlax-3d-point
                (mapcar 'append tCenLst (list (list 0.0) (list 0.0)))))
         (or (and (> Thtov 0.0) (setq tht Thtov)) (setq tht (getvar "TEXTSIZE")))
         (setq Area_text (mapcar 'vla-AddText (list spc spc)
                     (mapcar '(lambda (str) (strcat "Area: " (rtos str)))
                         AreaLst)
                     tCen (list tht tht)))
         (mapcar 'vla-put-color Area_text (list acRed acGreen))
         (mapcar 'vla-move Area_text (mapcar 'vlax-3d-point (list '(0 0 0) '(0 0 0))) movp)
         (if Cenpt
       (progn
         (setvar "PDMODE" 3)
         (mapcar 'vla-Addpoint (list spc spc) tCen)))
         (if CurDel (vla-Delete cCur))
         
         (princ (strcat "\n<<<  Red Area: " (rtos (car AreaLst))
                ", Green Area: " (rtos (cadr AreaLst)) " >>>")))
       
       (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)

CarlB · 发表于 2022-7-5 19:03:50

李-

我也不确定，但在我的第一篇帖子中就说了。

对奥利弗来说，你发布的第一个例程不是做了你想做的吗？我让它工作了，但是有点难按照提示。

[编程交流] 切割面积

发表回复

精选推荐