Autocad应用程序：对象Wa

Lee Mac · 发表于 2022-7-6 08:49:45

大家好，

我刚刚完成了LISP的编写，如下所示，目前正在测试它。

我不断收到一条脾气不好的错误消息，有时会显示出来，有时LISP会成功完成。

但我一辈子都搞不清楚有时出了什么问题。

非常感谢您的帮助，谢谢您抽出时间。


;;;================= AreaDiv.lsp =================
;;;
;;; FUNCTION: AD (Area Division)
;;;
;;; Will Divide a Selected LWPolyline into
;;; a specified Area and remainder.
;;;
;;; AUTHOR:
;;; Copyright (C) 2009 Lee McDonnell
;;;  (Contact Lee Mac, CADTutor.net)
;;;
;;; PLATFORMS:
;;; No Restrictions, only tested on ACAD2004
;;;
;;; VERSION:
;;; 1.0   ~   29.03.2009
;;;
;;;===============================================
(defun c:AD (/ *error* ovar vlst doc spc ODel Acc ACol BCol 2Area
          Txt tAcc tHt TCol Ent cEnt cPt cAng p@sel cLen mArea
          ePara Paralst rArea pArea pInc i vPt tLine iArr iLst
          ptLst pLst sPara vpLst vPts tPoly 2vPts 2tPoly
          RLst ObjArr ObjReg rCentr tBoxes mOvPt txtObj AreaLst)
 ; === Adjustments ===
 (setq ODel nil)    ;  Delete Original LWPolyline (T = Del)
 (setq Acc 5.0)  ;  Accuracy of Area Retrieval (Tolerance)
 (setq ACol 3)    ;  Colour of Desired Region (0-255)
 (setq BCol 4)    ;  Colour of Second Region (if 2Area = T)
 (setq 2Area T)   ;  Secondary Marked Area (T or nil)
 (setq Txt T)     ;  Area Text in Regions (T or nil)
 (setq tAcc 2)    ;  Area Text Precision (if Txt = T)
 (setq tHt 2.5)   ;  Area Text Height (if Txt = T, 0.0 for Default)
 (setq TCol 2)    ;  Area Text Colour (if Txt = T)
 ; ===================
 ; === Error Prevention ===
 (or (< 0.0 Acc) (setq Acc 10.0))
 (or (and (eq 'INT (type ACol)) (<= 0 ACol 255)) (setq ACol 3))
 (or (and (eq 'INT (type ACol)) (<= 0 BCol 255)) (setq BCol 4))
 (or (and (eq 'INT (type tAcc)) (<= 0 tAcc))     (setq tAcc 2))
 (or (and (eq 'INT (type TCol)) (<= 0 TCol 255)) (setq TCol 2))
 (or (< 0.0 tHt) (setq tHt (getvar "TEXTSIZE")))
 (defun *error* (msg)
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg))))
   (princ))
 ; ========================
 (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)))
 (setq vlst '("OSMODE")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar vlst '(0))
 (if (and (setq Ent (entsel "\nSelect LWPolyline: "))
      (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car Ent))))))
   (progn
     (setq cEnt (vlax-ename->vla-object (car Ent))
       cPt (vlax-curve-getClosestPointto cEnt (cadr Ent) acExtendNone)
       cAng (angle '(0 0 0) (vlax-curve-getFirstDeriv cEnt
                  (vlax-curve-getParamatPoint cEnt cPt)))
       p@sel (vlax-curve-getParamAtPoint cEnt cPt)
       cLen (- (vlax-curve-getDistatParam cEnt (fix p@sel))
           (vlax-curve-getDistatParam cEnt (1+ (fix p@sel)))))
     (if (eq :vlax-false (vla-get-Closed cEnt))
   (progn
     (initget "Yes No")
     (if (eq "Yes" (getkword "\nPolyline Not Closed, Close it?  "))
       (vla-put-Closed cEnt :vlax-true))))
     (setq mArea (vla-get-Area cEnt) ePara (1+ (vlax-curve-getEndParam cEnt)))
     (while (not (minusp (setq ePara (1- ePara))))
   (setq Paralst (cons ePara Paralst)))
     (if (and (not (initget 7))
          (setq rArea (getreal (strcat "\nPline Area: "(rtos mArea 2 0)", Required: ")))
          (<= rArea mArea))
   (progn
     (setq pArea 0.0 pInc (/ Acc 500.0) i -1.0)
     ; === While Loop ===
     (while (and (not (equal rArea pArea Acc))
             (setq vPt (vlax-curve-getPointatParam cEnt (* pInc (setq i (1+ i))))))
       (setq tLine (vla-addLine spc (vlax-3D-Point vPt)
             (vlax-3D-Point (polar vPt cAng cLen)))
         iArr (vlax-variant-value
            (vla-IntersectWith tLine cEnt acExtendThisEntity)))
       (vla-Delete tLine)
       (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)))))
       (if (> (length ptLst) 1)
         (progn
       (setq pLst (vl-sort
                (mapcar
                  '(lambda (p) (vlax-curve-getParamatPoint cEnt p)) ptLst) '<)
             sPara (1+ (fix (car pLst))) pInts (list (car pLst) (cadr pLst)))
       (while (< sPara (cadr pLst))
         (setq pLst (append pLst (list sPara)) sPara (1+ sPara)))
       (setq vpLst (apply 'append
                 (mapcar '(lambda (x) (list (car x) (cadr x)))
                     (mapcar '(lambda (p) (vlax-curve-getPointatParam cEnt p)) (vl-sort pLst '<))))
             vPts (vlax-make-variant
                (vlax-safearray-fill
                  (vlax-make-safearray
                vlax-vbdouble
                (cons 0 (1- (length vpLst))))
                  vpLst))
             tPoly (vla-AddLightWeightPolyline spc vPts))
       (vla-put-Closed tPoly :vlax-true)
       (setq pArea (vla-get-Area tPoly))
       (or (equal rArea pArea Acc) (vla-Delete tPoly))))
       (setq ptLst nil))
       ; === End of Loop ===
     (if tPoly
       (progn
         (vla-put-color tPoly ACol)
         (if 2Area
       (progn
         (setq Paralst (apply 'append
                  (mapcar '(lambda (w) (list (car w) (cadr w)))
                      (mapcar '(lambda (y) (vlax-curve-getPointatParam cEnt y))
                          (vl-sort
                            (append pInts (vl-remove-if
                                    '(lambda (m) (member m pLst)) Paralst)) '<))))
           2vPts (vlax-make-variant
               (vlax-safearray-fill
                 (vlax-make-safearray
                   vlax-vbDouble
                   (cons 0 (1- (length Paralst))))
                 Paralst))
           2tPoly (vla-addLightWeightPolyline spc 2vPts))
         (vla-put-Closed 2tPoly :vlax-true)
         (vla-put-Color 2tPoly BCol) (setq RLst (list tPoly 2tPoly)))
       (setq RLst (list tPoly)))
         (if Txt
       (progn
         (setq ObjArr (vlax-safearray-fill
                (vlax-make-safearray
                  vlax-vbObject
                  (cons 0 (1- (length RLst))))
                RLst)
           ObjReg (vlax-safearray->list
                (vlax-variant-value
                  (vla-addRegion spc ObjArr)))
           rCentr (mapcar '(lambda (x) (vlax-safearray->list
                             (vlax-variant-value
                           (vla-get-Centroid x)))) ObjReg)
           tBoxes (mapcar '(lambda (x) (textbox (list (cons 1 x))))
                      (setq AreaLst (mapcar '(lambda (y) (strcat "Area: " (rtos y 2 tAcc)))
                                (mapcar 'vla-get-Area RLst))))
           mOvPt  (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))) tBoxes))
           rCentr (mapcar 'vlax-3D-Point
                      (mapcar '(lambda (x) (append x '(0.0))) rCentr))
           txtObj (mapcar '(lambda (x y) (vla-addText spc x y tHt)) AreaLst rCentr))
         
         (cond ((eq 1 (length RLst))
            (vla-Move (car txtObj) (vlax-3D-Point '(0 0 0)) (car mOvPt))
            (vla-put-Color (car txtObj) TCol)
            (vla-put-Color (car ObjReg) ACol)
            (vla-delete tPoly))
           ((eq 2 (length RLst))
            (mapcar 'vla-Move txtObj
                (mapcar 'vlax-3D-Point '((0 0 0) (0 0 0))) mOvPt)
            (mapcar 'vla-put-Color txtObj (list TCol TCol))
            (mapcar 'vla-put-Color ObjReg (list ACol BCol))
            (mapcar 'vla-Delete (list tPoly 2tPoly))))))
         (if ODel (vla-Delete cEnt)))
       (princ "\n<!> Unable to Partition Area <!>")))
   (princ "\n<!> Area is Greater than Area of Selected Pline <!>")))
   (princ "\n<!> Nothing Selected, or this isn't an LWPline <!>"))
 (mapcar 'setvar vlst ovar)
 (princ))

ASMI · 发表于 2022-7-6 08:56:06

使用（if（not（vlax-erased-p tPoly））可以确信您的多段线没有被擦除，或者在（vla Delete tPoly）之后使用（setq tPoly nil）。

使用（vla Delete tPoly）不会更改tPoly变量值。

Lee Mac · 发表于 2022-7-6 08:58:51

啊，说得好！

我认为，由于这是一个迭代过程-有可能在公差（Acc）内找不到区域-但由于tPoly未设置为零，LISP仍将尝试继续。。。

非常感谢ASMI，我会试一试的

干杯

李

Lee Mac · 发表于 2022-7-6 09:00:34

非常感谢ASMI-vlax-erased-p带来的惊喜。

Lee Mac · 发表于 2022-7-6 09:02:54

发现了其他一些小故障，如区域被标记为错误的方向，但现在似乎都已修复

它有时无法划分区域，我认为这是因为（作为一个迭代过程），在循环到达曲线末端之前，区域不会达到公差集内-但减少增量步长只会减慢程序的速度。

但无论如何，这里有一个最终结果：

copy


;;;================= AreaDiv.lsp =================
;;;
;;; FUNCTION: AD (Area Division)
;;;
;;; Will Divide a Selected LWPolyline into
;;; a specified Area and remainder.
;;;
;;; AUTHOR:
;;; Copyright (C) 2009 Lee McDonnell
;;;  (Contact Lee Mac, CADTutor.net)
;;;
;;; PLATFORMS:
;;; No Restrictions, only tested on ACAD2004
;;;
;;; VERSION:
;;; 1.0   ~   29.03.2009
;;;
;;; RESTRICTIONS:
;;; Iterative Process, will unsuccessfully
;;; partition region if tolerance is too low.
;;;
;;;===============================================
(defun c:AD (/ *error* ovar vlst doc spc ODel Acc ACol BCol 2Area
          Txt tAcc tHt TCol Ent cEnt cPt cAng p@sel cLen mArea
          ePara Paralst rArea pArea pInc i vPt tLine iArr iLst
          ptLst pLst sPara vpLst vPts tPoly 2vPts 2tPoly
          RLst ObjArr ObjReg rCentr tBoxes mOvPt txtObj AreaLst)
 ; === Adjustments ===
 (setq ODel nil)    ;  Delete Original LWPolyline (T = Del)
 (setq Acc 5.0)  ;  Accuracy of Area Retrieval (Tolerance)
 (setq ACol 3)    ;  Colour of Desired Region (0-255)
 (setq BCol 4)    ;  Colour of Second Region (if 2Area = T)
 (setq 2Area T)   ;  Secondary Marked Area (T or nil)
 (setq Txt T)     ;  Area Text in Regions (T or nil)
 (setq tAcc 2)    ;  Area Text Precision (if Txt = T)
 (setq tHt 2.5)   ;  Area Text Height (if Txt = T, 0.0 for Default)
 (setq TCol 2)    ;  Area Text Colour (if Txt = T)
 ; ===================
 ; === Error Prevention ===
 (or (< 0.0 Acc) (setq Acc 10.0))
 (or (and (eq 'INT (type ACol)) (<= 0 ACol 255)) (setq ACol 3))
 (or (and (eq 'INT (type ACol)) (<= 0 BCol 255)) (setq BCol 4))
 (or (and (eq 'INT (type tAcc)) (<= 0 tAcc))     (setq tAcc 2))
 (or (and (eq 'INT (type TCol)) (<= 0 TCol 255)) (setq TCol 2))
 (or (< 0.0 tHt) (setq tHt (getvar "TEXTSIZE")))
 (defun *error* (msg)
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg))))
   (princ))
 ; ========================
 (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)))
 (setq vlst '("OSMODE")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar vlst '(0))
 (if (and (setq Ent (entsel "\nSelect LWPolyline: "))
      (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car Ent))))))
   (progn
     (setq cEnt (vlax-ename->vla-object (car Ent))
       cPt (vlax-curve-getClosestPointto cEnt (cadr Ent) acExtendNone)
       cAng (angle '(0 0 0) (vlax-curve-getFirstDeriv cEnt
                  (vlax-curve-getParamatPoint cEnt cPt)))
       p@sel (vlax-curve-getParamAtPoint cEnt cPt)
       cLen (- (vlax-curve-getDistatParam cEnt (fix p@sel))
           (vlax-curve-getDistatParam cEnt (1+ (fix p@sel)))))
     (if (eq :vlax-false (vla-get-Closed cEnt))
   (progn
     (initget "Yes No")
     (if (eq "Yes" (getkword "\nPolyline Not Closed, Close it?  "))
       (vla-put-Closed cEnt :vlax-true))))
     (setq mArea (vla-get-Area cEnt) ePara (1+ (vlax-curve-getEndParam cEnt)))
     (while (not (minusp (setq ePara (1- ePara))))
   (setq Paralst (cons ePara Paralst)))
     (if (and (not (initget 7))
          (setq rArea (getreal (strcat "\nPline Area: "(rtos mArea 2 0)", Required: ")))
          (<= rArea mArea))
   (progn
     (setq pArea 0.0 pInc (/ Acc 500.0) i -1.0)
     ; === While Loop ===
     (while (and (not (equal rArea pArea Acc))
             (setq vPt (vlax-curve-getPointatParam cEnt (* pInc (setq i (1+ i))))))
       (setq tLine (vla-addLine spc (vlax-3D-Point vPt)
             (vlax-3D-Point (polar vPt cAng cLen)))
         iArr (vlax-variant-value
            (vla-IntersectWith tLine cEnt acExtendThisEntity)))
       (and (vla-Delete tLine) (setq tLine nil))
       (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)))))
       (if (> (length ptLst) 1)
         (progn
       (setq pLst (vl-sort
                (mapcar
                  '(lambda (p) (vlax-curve-getParamatPoint cEnt p)) ptLst) '<)
             sPara (1+ (fix (car pLst))) pInts (list (car pLst) (cadr pLst)))
       (while (< sPara (cadr pLst))
         (setq pLst (append pLst (list sPara)) sPara (1+ sPara)))
       (setq vpLst (apply 'append
                 (mapcar '(lambda (x) (list (car x) (cadr x)))
                     (mapcar '(lambda (p) (vlax-curve-getPointatParam cEnt p)) (vl-sort pLst '<))))
             vPts (vlax-make-variant
                (vlax-safearray-fill
                  (vlax-make-safearray
                vlax-vbdouble
                (cons 0 (1- (length vpLst))))
                  vpLst))
             tPoly (vla-AddLightWeightPolyline spc vPts))
       (if (not (vlax-erased-p tPoly)) (vla-put-Closed tPoly :vlax-true))
       (setq pArea (vla-get-Area tPoly))
       (or (equal rArea pArea Acc) (and (vla-Delete tPoly) (setq tPoly nil)))))
       (setq ptLst nil))
       ; === End of Loop ===
     (if (not (vlax-erased-p tPoly))
       (progn
         (vla-put-color tPoly ACol)
         (if 2Area
       (progn
         (setq Paralst (apply 'append
                  (mapcar '(lambda (w) (list (car w) (cadr w)))
                      (mapcar '(lambda (y) (vlax-curve-getPointatParam cEnt y))
                          (vl-sort
                            (append pInts (vl-remove-if
                                    '(lambda (m) (member m pLst)) Paralst)) '<))))
           2vPts (vlax-make-variant
               (vlax-safearray-fill
                 (vlax-make-safearray
                   vlax-vbDouble
                   (cons 0 (1- (length Paralst))))
                 Paralst))
           2tPoly (vla-addLightWeightPolyline spc 2vPts))
         (vla-put-Closed 2tPoly :vlax-true)
         (vla-put-Color 2tPoly BCol) (setq RLst (list tPoly 2tPoly)))
       (setq RLst (list tPoly)))
         (if Txt
       (progn
         (setq ObjArr (vlax-safearray-fill
                (vlax-make-safearray
                  vlax-vbObject
                  (cons 0 (1- (length RLst))))
                RLst)
           ObjReg (vlax-safearray->list
                (vlax-variant-value
                  (vla-addRegion spc ObjArr))))
         
         (if (< 1 (length ObjReg))
           (setq ObjReg (vl-sort ObjReg '(lambda (x1 x2)
                           (< (abs (- rArea (vla-get-Area x1)))
                              (abs (- rArea (vla-get-Area x2))))))))
                     
         (setq rCentr (mapcar '(lambda (x) (vlax-safearray->list
                             (vlax-variant-value
                           (vla-get-Centroid x)))) ObjReg)
           tBoxes (mapcar '(lambda (x) (textbox (list (cons 1 x))))
                      (setq AreaLst (mapcar '(lambda (y) (strcat "Area: " (rtos y 2 tAcc)))
                                (mapcar 'vla-get-Area RLst))))
           mOvPt  (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))) tBoxes))
           rCentr (mapcar 'vlax-3D-Point
                      (mapcar '(lambda (x) (append x '(0.0))) rCentr))
           txtObj (mapcar '(lambda (x y) (vla-addText spc x y tHt)) AreaLst rCentr))
         
         (cond ((eq 1 (length RLst))
            (vla-Move (car txtObj) (vlax-3D-Point '(0 0 0)) (car mOvPt))
            (vla-put-Color (car txtObj) TCol)
            (vla-put-Color (car ObjReg) ACol)
            (and (vla-delete tPoly) (setq tPoly nil)))
           ((eq 2 (length RLst))
            (mapcar 'vla-Move txtObj
                (mapcar 'vlax-3D-Point '((0 0 0) (0 0 0))) mOvPt)
            (mapcar 'vla-put-Color txtObj (list TCol TCol))
            (mapcar 'vla-put-Color ObjReg (list ACol BCol))
            (mapcar 'vla-Delete (list tPoly 2tPoly))))))
         (if ODel (vla-Delete cEnt)))
       (princ "\n<!> Unable to Partition Area <!>")))
   (princ "\n<!> Area is Greater than Area of Selected Pline <!>")))
   (princ "\n<!> Nothing Selected, or this isn't an LWPline <!>"))
 (mapcar 'setvar vlst ovar)
 (princ))

Oliver · 发表于 2022-7-6 09:08:22

copy

Command: ad
Select LWPolyline:
Pline Area: 3312, Required: 1500
<!> Unable to Partition Area <!>
Command:
Command:
Command: _.erase 1 found
Command: re
REGEN Regenerating model.
Command: ad
Select LWPolyline:
Pline Area: 6706, Required: 3000
<!> Unable to Partition Area <!>
Command:

我正在使用autodesk land desktop 2009。。

Lee Mac · 发表于 2022-7-6 09:14:35

它应该解决这个问题——但正如我前面所说的那样——需要调整公差和增量步长，以帮助它一致地检索所需区域。

Oliver · 发表于 2022-7-6 09:17:25

最后现在它的工作降级到acad2007。。
非常感谢。

奥利弗

Lee Mac · 发表于 2022-7-6 09:20:23

很高兴你成功了-我不喜欢函数的迭代方法-它们大多不可靠，可靠性可能会因用户输入而有所不同。。。例如，在我的代码中，很难在大区域中找到一个小区域，必须对容差和增量步骤进行很大修改。

但是我认为这种方法是你在这个请求中能得到的最好的方法，我当然想不出另一种方法来执行这样的任务，如果其他人可以的话，我会感兴趣的。。。。

干杯

李

Oliver · 发表于 2022-7-6 09:23:50

我一直在看这个和相关的线程，但由于有限的Lisp经验，没有能够添加太多。然而，我可以肯定地看到局势的复杂性。

经过进一步思考，我很想知道这个过程将如何处理这里所示的情况，以及下面的简化形式。

在“简化”中，在60和64平方单位的目标区域中似乎存在不连续性。

[编程交流] Autocad应用程序：对象Wa

发表回复

精选推荐