Autocad应用程序：对象Wa
大家好，我刚刚完成了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))
使用（if（not（vlax-erased-p tPoly））可以确信您的多段线没有被擦除，或者在（vla Delete tPoly）之后使用（setq tPoly nil）。
使用（vla Delete tPoly）不会更改tPoly变量值。
啊，说得好！
我认为，由于这是一个迭代过程-有可能在公差（Acc）内找不到区域-但由于tPoly未设置为零，LISP仍将尝试继续。。。
非常感谢ASMI，我会试一试的
干杯
李 非常感谢ASMI-vlax-erased-p带来的惊喜。 发现了其他一些小故障，如区域被标记为错误的方向，但现在似乎都已修复
它有时无法划分区域，我认为这是因为（作为一个迭代过程），在循环到达曲线末端之前，区域不会达到公差集内-但减少增量步长只会减慢程序的速度。
但无论如何，这里有一个最终结果：
;;;================= 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))
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。。
它应该解决这个问题——但正如我前面所说的那样——需要调整公差和增量步长，以帮助它一致地检索所需区域。 最后现在它的工作降级到acad2007。。
非常感谢。
奥利弗
很高兴你成功了-我不喜欢函数的迭代方法-它们大多不可靠，可靠性可能会因用户输入而有所不同。。。例如，在我的代码中，很难在大区域中找到一个小区域，必须对容差和增量步骤进行很大修改。
但是我认为这种方法是你在这个请求中能得到的最好的方法，我当然想不出另一种方法来执行这样的任务，如果其他人可以的话，我会感兴趣的。。。。
干杯
李 我一直在看这个和相关的线程，但由于有限的Lisp经验，没有能够添加太多。然而，我可以肯定地看到局势的复杂性。
经过进一步思考，我很想知道这个过程将如何处理这里所示的情况，以及下面的简化形式。
在“简化”中，在60和64平方单位的目标区域中似乎存在不连续性。
页:
[1]
2