Q、 修剪多条多段线
我必须在一个配置文件中绘制灰色线，并修剪它们，如第一个附加的jpeg所示。不同颜色的线是多段线。基本上，EXTRIM可以完成一半的工作，因为它不允许您选择多条多段线。
使用线程“折线顶点”中发布的修改代码，我尝试了为单个水平线制作一些东西。
基本上，这段代码会找到沿单个选定水平线的所有交点，然后每隔2个交点绘制一条新线，然后删除旧线。
当代码正确时，我将让程序创建水平线，并将此代码应用于每一条。
目前存在的问题：
[列表]
[*]我必须按顺序选择多段线。这是一个问题，因为最终我想自动选择这些普林斯过滤层“地线”。
[*]如果第一条多段线中的初始线从上到右下，则绘制的线将与我想要的相反（请参见第二张图像（Profile2））。
你认为这是解决这个问题的最好办法吗？
谢谢大家的帮助。
附加图像https://www.cadtutor.net/forum/attachment.php?attachmentid=12827&stc=1&d=1246245669https://www.cadtutor.net/forum/attachment.php?attachmentid=12828&stc=1&d=1246245678 很好的工具，不能给你太多的帮助在Lisp程序，但我会遵循这一点，因为我可以使用这样的工具了。 试着用另一种方法
(defun c:Int(/ lne lObj ss int Objlst par lst ang)
(vl-load-com)
(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)))
(while
(progn
(setq lne (car (entsel "\nSelect Horizontal Line: ")))
(cond ((eq 'ENAME (type lne))
(if (eq "LINE" (dxf 0 lne))
(if (zerop (- (cadr (dxf 11 lne)) (cadr (dxf 10 lne))))
(progn
(setq lObj (vlax-ename->vla-object lne))
nil)
(princ "\n** Line is not Horizontal **"))
(princ "\n** Object is not a Line **")))
(t (princ "\n** Nothing Selected **")))))
(princ "\nSelect Polylines: ")
(while (not ss)
(setq ss (ssget '((0 . "LWPOLYLINE")))))
(setq int
(vl-sort
(apply 'append
(vl-remove-if 'null
(mapcar
(function
(lambda (Obj)
(vlax-lst->3D-point
(vlax-invoke lObj
'Intersectwith Obj acExtendNone))))
(setq Objlst
(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp
(mapcar 'cadr (ssnamex ss))))))))
(function
(lambda (a b)
(< (car a) (car b))))) lst Objlst)
(while
(and (setq Obj (car lst))
(not
(setq par
(vlax-curve-getParamatPoint Obj (car int)))))
(setq lst (cdr lst)))
(setq ang
(angle '(0 0 0)
(vlax-curve-getFirstDeriv Obj par)))
(if (or (< (/ pi 2.) ang pi)
(< (/ (* 3 pi) 2.) ang))
(setq int (cdr int)))
(setq lst Objlst)
(while
(and (setq Obj (car lst))
(not
(setq par
(vlax-curve-getParamatPoint Obj (last int)))))
(setq lst (cdr lst)))
(setq ang
(angle '(0 0 0)
(vlax-curve-getFirstDeriv Obj par)))
(if (or (> (/ pi 2.) ang 0.)
(< pi ang (/ (* 3 pi) 2.)))
(setq int
(reverse
(cdr
(reverse int)))))
(setq int
(mapcar 'vlax-3D-point int))
(while (cadr int)
(vla-addLine spc
(car int) (cadr int))
(setq int (cddr int)))
(vla-delete lObj)
(princ))
(defun dxf(code ent)
(cdr (assoc code (entget ent))))
(defun vlax-lst->3D-point(lst)
(if lst
(cons (list (car lst) (cadr lst) (caddr lst))
(vlax-lst->3D-point (cdddr lst)))))
不必按顺序选择多段线 正如所料，它工作得很好。谢谢伙计
要是我懂vlisp就好了！我下载了《VLISP开发者圣经》，也许有一天我会。。。
现在，我希望有了所有这些vlisp，如果我将其插入autolisp代码中，这将无关紧要。
是的，我很高兴它对你有用。
李 好的，使用代码并将其应用于选择集相当容易。如果其他人感兴趣，请点击这里：
(defun c:Int2(/ i lne lObj ss_GL ss_grey_lines int Objlst par lst ang)
(vl-load-com)
(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 (setq ss_grey_lines (ssget "X" (list (cons 0 "LINE") (cons 8 "Profile") (cons 62 )))
(Progn
(If (setq ss_GL (ssget "X" (list (cons 0 "POLYLINE") (cons 8 "Ground Line Profile"))))
(Progn
(setq i -1)
(while (setq lne (ssname ss_grey_lines (setq i (1+ i))))
(setq lObj (vlax-ename->vla-object lne))
;;;(while
;;; (progn
;;; (setq lne (car (entsel "\nSelect Horizontal Line: ")))
;;; (cond ((eq 'ENAME (type lne))
;;; (if (eq "LINE" (dxf 0 lne))
;;; (if (zerop (- (cadr (dxf 11 lne)) (cadr (dxf 10 lne))))
;;; (progn
;;; (setq lObj (vlax-ename->vla-object lne))
;;; nil)
;;; (princ "\n** Line is not Horizontal **"))
;;; (princ "\n** Object is not a Line **")))
;;; (t (princ "\n** Nothing Selected **")))))
(setq int
(vl-sort
(apply 'append
(vl-remove-if 'null
(mapcar
(function
(lambda (Obj)
(vlax-lst->3D-point
(vlax-invoke lObj
'Intersectwith Obj acExtendNone))))
(setq Objlst
(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp
(mapcar 'cadr (ssnamex ss_GL))))))))
(function
(lambda (a b)
(< (car a) (car b))))) lst Objlst)
(while
(and (setq Obj (car lst))
(not
(setq par
(vlax-curve-getParamatPoint Obj (car int)))))
(setq lst (cdr lst)))
(setq ang
(angle '(0 0 0)
(vlax-curve-getFirstDeriv Obj par)))
(if (or (< (/ pi 2.) ang pi)
(< (/ (* 3 pi) 2.) ang))
(setq int (cdr int)))
(setq lst Objlst)
(while
(and (setq Obj (car lst))
(not
(setq par
(vlax-curve-getParamatPoint Obj (last int)))))
(setq lst (cdr lst)))
(setq ang
(angle '(0 0 0)
(vlax-curve-getFirstDeriv Obj par)))
(if (or (> (/ pi 2.) ang 0.)
(< pi ang (/ (* 3 pi) 2.)))
(setq int
(reverse
(cdr
(reverse int)))))
(setq int
(mapcar 'vlax-3D-point int))
(while (cadr int)
(vla-addLine spc
(car int) (cadr int))
(setq int (cddr int)))
(vla-delete lObj)
) ; End While
)(Princ "Layer \"Ground Line Profile\" not found"))
)(Princ "Grey Lines not found"))
(princ))
(defun dxf(code ent)
(cdr (assoc code (entget ent))))
(defun vlax-lst->3D-point(lst)
(if lst
(cons (list (car lst) (cadr lst) (caddr lst))
(vlax-lst->3D-point (cdddr lst)))))
我注意到的一点是，它将水平线更改为当前图层和颜色。我还没来得及破译visualLisp，你能给我看看快速修复方法吗？我希望线条保持原来的颜色，即“轮廓”层，颜色8。
谢谢
很高兴史蒂夫有机会亲自修改它
我会帮你的 这应该行得通，尽管它没有太多的错误捕捉方式（如检查线是否水平等），如有必要，可以添加此项。
另外，请记住，您只是收集多段线，而不是LWPolyline，只是想让您知道这一点，因为我不确定这是否是您的意图。
(defun c:Int(/ doc spc ss_grey ss_gl lne
lObj ss int Objlst par lst ang)
(vl-load-com)
(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 (setq ss_grey
(ssget "_X" '((0 . "LINE") (8 . "Profile") (62 . )))
(if (setq ss_gl
(ssget "_X" '((0 . "POLYLINE") (8 . "Ground Line Profile"))))
(foreach lObj (mapcar 'vlax-ename->vla-object
(mapcar 'cadr (ssnamex ss_grey)))
;;;(while
;;; (progn
;;; (setq lne (car (entsel "\nSelect Horizontal Line: ")))
;;; (cond ((eq 'ENAME (type lne))
;;; (if (eq "LINE" (dxf 0 lne))
;;; (if (zerop (- (cadr (dxf 11 lne)) (cadr (dxf 10 lne))))
;;; (progn
;;; (setq lObj (vlax-ename->vla-object lne))
;;; nil)
;;; (princ "\n** Line is not Horizontal **"))
;;; (princ "\n** Object is not a Line **")))
;;; (t (princ "\n** Nothing Selected **")))))
;;;
;;;(princ "\nSelect Polylines: ")
;;;(while (not ss)
;;; (setq ss (ssget '((0 . "LWPOLYLINE")))))
(setq int
(vl-sort
(apply 'append
(vl-remove-if 'null
(mapcar
(function
(lambda (Obj)
(vlax-lst->3D-point
(vlax-invoke lObj
'Intersectwith Obj acExtendNone))))
(setq Objlst
(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp
(mapcar 'cadr (ssnamex ss))))))))
(function
(lambda (a b)
(< (car a) (car b))))) lst Objlst)
(while
(and (setq Obj (car lst))
(not
(setq par
(vlax-curve-getParamatPoint Obj (car int)))))
(setq lst (cdr lst)))
(setq ang
(angle '(0 0 0)
(vlax-curve-getFirstDeriv Obj par)))
(if (or (< (/ pi 2.) ang pi)
(< (/ (* 3 pi) 2.) ang))
(setq int (cdr int)))
(setq lst Objlst)
(while
(and (setq Obj (car lst))
(not
(setq par
(vlax-curve-getParamatPoint Obj (last int)))))
(setq lst (cdr lst)))
(setq ang
(angle '(0 0 0)
(vlax-curve-getFirstDeriv Obj par)))
(if (or (> (/ pi 2.) ang 0.)
(< pi ang (/ (* 3 pi) 2.)))
(setq int
(reverse
(cdr
(reverse int)))))
(setq int
(mapcar 'vlax-3D-point int))
(while (cadr int)
(setq nLne
(vla-addLine spc
(car int) (cadr int)))
(vla-put-layer nLne "Profile")
(vla-put-color nLne
(setq int (cddr int)))
(vla-delete lObj))
(princ "\n<< No Polylines Found >>"))
(princ "\n<< No Lines Found >>"))
(princ))
(defun dxf(code ent)
(cdr (assoc code (entget ent))))
(defun vlax-lst->3D-point(lst)
(if lst
(cons (list (car lst) (cadr lst) (caddr lst))
(vlax-lst->3D-point (cdddr lst)))))
李 在这里，有时选择集中的水平线根本不会与多段线相交。我想不出一个办法来忽略这些台词。。。 啊，当然，我没有考虑到这一点-这应该是原因：
4
页:
[1]
2