Q、修剪多条多段线

SteveK · 发表于 2022-7-6 12:50:36

我必须在一个配置文件中绘制灰色线，并修剪它们，如第一个附加的jpeg所示。

不同颜色的线是多段线。基本上，EXTRIM可以完成一半的工作，因为它不允许您选择多条多段线。

使用线程“折线顶点”中发布的修改代码，我尝试了为单个水平线制作一些东西。

基本上，这段代码会找到沿单个选定水平线的所有交点，然后每隔2个交点绘制一条新线，然后删除旧线。

当代码正确时，我将让程序创建水平线，并将此代码应用于每一条。

目前存在的问题：
[列表]

我必须按顺序选择多段线。这是一个问题，因为最终我想自动选择这些普林斯过滤层“地线”。

如果第一条多段线中的初始线从上到右下，则绘制的线将与我想要的相反（请参见第二张图像（Profile2））。
你认为这是解决这个问题的最好办法吗？
谢谢大家的帮助。
附加图像https://www.cadtutor.net/forum/attachment.php?attachmentid=12827&stc=1&d=1246245669[/img]

登录/注册后可看大图

fuqua · 发表于 2022-7-6 12:54:06

很好的工具，不能给你太多的帮助在Lisp程序，但我会遵循这一点，因为我可以使用这样的工具了。

Lee Mac · 发表于 2022-7-6 12:58:55

试着用另一种方法

copy


(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)))))

不必按顺序选择多段线

SteveK · 发表于 2022-7-6 13:03:13

正如所料，它工作得很好。谢谢伙计
要是我懂vlisp就好了！我下载了《VLISP开发者圣经》，也许有一天我会。。。
现在，我希望有了所有这些vlisp，如果我将其插入autolisp代码中，这将无关紧要。

Lee Mac · 发表于 2022-7-6 13:05:01

是的，我很高兴它对你有用。

李

SteveK · 发表于 2022-7-6 13:09:23

好的，使用代码并将其应用于选择集相当容易。如果其他人感兴趣，请点击这里：

copy


(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。
谢谢

Lee Mac · 发表于 2022-7-6 13:12:11

很高兴史蒂夫有机会亲自修改它

我会帮你的

Lee Mac · 发表于 2022-7-6 13:15:06

这应该行得通，尽管它没有太多的错误捕捉方式（如检查线是否水平等），如有必要，可以添加此项。

另外，请记住，您只是收集多段线，而不是LWPolyline，只是想让您知道这一点，因为我不确定这是否是您的意图。

copy


(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)))))