;; Open Polylines at Selected Edge
;; Copyright © 2009 Lee McDonnell ~ 20.08.2009
(defun c:PlOpen (/ doc ent Obj pPar pCrds lst Blg i Wid st en)
(vl-load-com)
(setq doc (vla-get-ActiveDocument
(vlax-get-acad-object)))
(if (and (setq ent (entsel "\nSelect LWPolyline: "))
(eq "AcDbPolyline"
(vla-get-ObjectName
(setq Obj (vlax-ename->vla-object (car ent))))))
(if (eq :vlax-true (vla-get-Closed Obj))
(progn
(vla-StartUndoMark doc)
(setq pPar
(1+
(fix
(vlax-curve-getParamatPoint Obj
(vlax-curve-getClosestPointto Obj (cadr ent))))))
(setq pCrds
(vlax-list->2D-point
(vlax-safearray->list
(vlax-variant-value
(vla-get-Coordinates Obj))))
lst (list (fix (vlax-curve-getStartParam Obj))) i -1)
(repeat (1- (length pCrds))
(setq lst (cons (1+ (car lst)) lst)))
(setq Blg
(remake-list
(mapcar
(function
(lambda (x)
(vla-getBulge Obj x)))
(reverse lst))
pPar))
(foreach x (reverse lst)
(vla-getWidth Obj x 'st 'en)
(setq Wid (cons (cons st en) Wid)))
(setq Wid (remake-list (reverse Wid) pPar))
(vla-put-Coordinates Obj
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbdouble (cons 0 (1- (* (length pCrds) 2))))
(apply 'append (remake-list pCrds pPar)))))
(mapcar
(function
(lambda (x y)
(vla-setBulge Obj
(setq i (1+ i)) x)
(vla-SetWidth Obj i (car y) (cdr y)))) Blg Wid)
(vla-put-closed Obj :vlax-false)
(vla-EndUndoMark doc))
(princ "\n** LWPolyline not Closed **"))
(princ "\n** Object Not an LWPolyline **"))
(princ))
(defun vlax-list->2D-point (lst)
(if lst
(cons (list (car lst) (cadr lst))
(vlax-list->2D-point (cddr lst)))))
(defun Remake-List (lst i / j k)
(setq j -1 k -1)
(append
(vl-remove-if
(function
(lambda (x)
(< (setq j (1+ j)) i))) lst)
(vl-remove-if
(function
(lambda (x)
(>= (setq k (1+ k)) i))) lst)))
确实如此！非常感谢。
没问题-我做得很开心 我之前没有想过，但是使用这个和只使用trim有什么区别？
拾取柱脚线，拾取柱脚线中的线段。
不知道你可以用那种方式修剪
我对使用AutoCAD的缺乏经验再次打击了…：眨眼： 我不知道为什么我没有早点考虑。我一看到它张贴在theswamp上，就意识到了这一点。因为这是一个请求，我想我应该发布信息。 你好
只是为了好玩。
使用entmod更简洁一些（也适用于打开的多段线）。
(defun c:PlOpen (/ pl pt pa l1 l2 l3 cl)
(vl-load-com)
(if (and
(setq pl (entsel "\nSelect the pline segment: "))
(setq pt (trans (osnap (cadr pl) "_nea") 1 0))
(setq pl (car pl))
(setq el (entget pl))
(= "LWPOLYLINE" (cdr (assoc 0 el)))
)
(progn
(foreach p el
(if (member (car p) '(10 40 41 42))
(setq l2 (cons p l2))
(setq l1 (cons p l1))
)
)
(setq l2 (reverse l2)
cl (assoc 70 el)
)
(repeat (* 4 (1+ (fix (vlax-curve-getParamAtPoint pl pt))))
(setq l2 (append (cdr l2) (list (car l2))))
)
(entmod (append (subst (cons 70 (Boole 2 (cdr cl) 1)) cl (reverse l1)) l2)
)
)
)
(princ)
) 嘿，吉尔！
很高兴在这些地方见到你-欢迎来到CADTutor
我在theSwamp上看到了ElpanoveGeniy的一个类似方法——聪明的东西：眨眼： 如何更改此例程以添加圆弧，而不是使用删除线段
（vla setbulge（vlax ename->vla对象（car（entsel）））0 1） 伦曼茨
(setq pl (entsel)
pt (trans (osnap (cadr pl) "_nea") 1 0)
pl (car pl)
pa (fix (vlax-curve-getParamAtPoint pl pt))
)
(vla-setbulge (vlax-ename->vla-object pl) pa 1.0)
但这里有一个完整的例程，我写了很多次了
;; CRUV (gile) -Gilles Chanteau-
;; Transforms a straight polyline segment into a curve one
(defun c:curv (/ *error* pl pt no scu pa p1 p2 bu mid cor loop gr pm fl
str ce di)
(vl-load-com)
(or *acdoc*
(setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(defun *error* (msg)
(or (= msg "Function cancelled")
(princ (strcat "Error: " msg))
)
(vla-SetBulge pl pa bu)
(and scu
(vl-cmdf "_.ucs" "_restore" "scuinit")
(vl-cmdf "_.ucs" "_delete" "scuinit")
)
(grtext)
(redraw)
(vla-EndUndoMark *acdoc*)
)
(if
(and
(setq pl (entsel))
(setq pt (trans (osnap (cadr pl) "_nea") 1 0))
(setq no (cdr (assoc 210 (entget (car pl)))))
(setq pl (vlax-ename->vla-object (car pl)))
(= (vla-get-ObjectName pl) "AcDbPolyline")
)
(progn
(vla-StartUndoMark *acdoc*)
(if (not
(and (equal '(0 0 1)
(trans '(0 0 1) no 1 T)
1e-9
)
(equal 0.0 (vla-get-elevation pl) 1e-9)
)
)
(and
(vl-cmdf "_.ucs" "_save" "scuinit")
(setq scu T)
(vl-cmdf "_.ucs" "_object" (vlax-vla-object->ename pl))
)
)
(setq pa (fix (vlax-curve-getParamAtPoint pl pt))
p1 (trans (vlax-curve-getPointatParam pl pa) 0 no)
p2 (trans (vlax-curve-getPointatParam pl (1+ pa)) 0 no)
bu (vla-GetBulge pl pa)
mid(mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p1 p2)
cor(distance mid p1)
loop T
)
(princ "\nSpecify the height (sagitta) or : ")
(while (and (setq gr (grread T 12 0)) (/= (car gr) 3) loop)
(cond
((= (car gr) 5)
(redraw)
(setq pm (trans (cadr gr) 1 no)
fl (distance mid pm)
)
(and (< (sin (- (angle p1 p2) (angle p1 pm))) -1e-14)
(setq fl (- fl))
)
(vla-setBulge
pl
pa
((lambda (a) (/ (sin a) (cos a)))
(/ (- (angle p2 pm) (angle pm p1)) 2.0)
)
)
(grdraw (trans mid no 1)
(trans (vlax-curve-getPointAtParam pl (+ pa 0.5)) 0 1)
-1
1
)
(grtext -1 (strcat "Height = " (rtos fl)))
)
((member (cadr gr) '(13 32))
(cond
((and str (numberp (read str)))
(vla-setBulge pl pa (/ (read str) cor))
(setq loop nil)
)
((and str (member (strcase str) '("C" "D")))
(setq loop nil)
(cond
((= (strcase str) "C")
(while
(not (and
(setq
ce
(trans (getpoint "\nSpecify le center: ")
1
no
)
)
(equal (distance ce p1) (distance ce p2) 1e-9)
)
)
(princ
"\nThe specified point can't be the arc center"
)
)
(vla-SetBulge
pl
pa
(/ (- (distance ce p1) (distance ce mid))
(if
(< (sin (- (angle p1 p2) (angle p1 ce))) -1e-14)
(distance p1 mid)
(- (distance p1 mid))
)
)
)
(initget "Yes No")
(if
(=
"Yes"
(getkword
"\nDraw the complementary arc ? <No>: "
)
)
(vla-SetBulge
pl
pa
(/ (+ (distance ce p1) (distance ce mid))
(if (< (sin (- (angle p1 p2) (angle p1 ce)))
-1e-14
)
(- cor)
cor
)
)
)
)
)
((= (strcase str) "D")
(while
(not (setq di (getpoint (trans p1 no 1)
"\nSpecify the direction: "
)
)
)
)
((lambda (a)
(vla-SetBulge pl pa (/ (sin a) (cos a)))
)
(/ (- (angle p1 p2) (angle p1 (trans di 1 no))) 2.0)
)
)
)
)
(T
(princ
"\nNeeds a number, a valid option or a cursor input.
\nSpecify the height (sagitta) or : "
)
(setq str "")
)
)
)
(T
(if (= (cadr gr)
(or
(and str
(/= str "")
(setq str (substr str 1 (1- (strlen str))))
(princ (chr )
(princ (chr 32))
)
(setq str nil)
)
(or
(and str (setq str (strcat str (chr (cadr gr)))))
(setq str (chr (cadr gr)))
)
)
(and str (princ (chr (cadr gr))))
)
)
)
(and scu
(vl-cmdf "_.ucs" "_restore" "scuinit")
(vl-cmdf "_.ucs" "_delete" "scuinit")
)
(grtext)
(redraw)
(vla-EndUndoMark *acdoc*)
)
)
(princ)
)
页:
1
[2]