[LISP函数]：给定多边形上两点,将多边形拆分为两部分

caddog

[PHP];;;--------------------------------------------------------
;;;函数： adj:sliptPts                               
;;;--------------------------------------------------------
;;;功能：用多边形上的两个点，将多边形分解为两个多边形
;;;参数：en-slipt　多边形实体　pt1-slipt　pt2-slipt　拆分点
;;;返回值　点集（多边形1　多边形2）
;;;--------------------------------------------------------
(defun adj:sliptPts( en-slipt pt1-slipt pt2-slipt / pts1-slipt #PTS1-SLIPT-1 #PTS1-SLIPT-2  PT3-SLIPT)   
  (setq pts1-slipt (mapcar '(lambda(y)(list (cadr y)(caddr y))) (vl-remove-if '(lambda(x) (/= 10 (car x))) (entget en-slipt))))
  ;;将pt1-slipt pt2-slipt加入到原多边形顶点集中，按参数进行排序
  (setq pts1-slipt (append pts1-slipt (list pt1-slipt pt2-slipt)))
  (setq
      pts1-slipt
       (vl-sort pts1-slipt
               (function
          (lambda        (e1 e2)
                                  (< (VLAX-CURVE-GETPARAMATPOINT en-slipt e1)
                                     (VLAX-CURVE-GETPARAMATPOINT en-slipt e2)
                                     )
                                  )
                  )
                )
      )
  ;;由此，多边形的点集变为:1 2 3 pt1-slipt 4 5 6 7 pt2-slipt 8
  ;;将之拆分为三段: (1 2 3 pt1-slipt)    (pt1-slipt 4 5 6 7 pt2-slipt)    (pt2-slipt 8)
  ;;组合:(1 2 3 pt1-slipt pt2-slipt 8) (pt1-slipt 4 5 6 7 pt2-slipt)
  ;;注意，无法区分pt1-slipt　pt2-slipt哪个在前，可以通过比较他们的参数来判断
  (if (> (VLAX-CURVE-GETPARAMATPOINT en-slipt pt1-slipt)(VLAX-CURVE-GETPARAMATPOINT en-slipt pt2-slipt))
    (setq pt3-slipt pt1-slipt
          pt1-slipt pt2-slipt
          pt2-slipt pt3-slipt)
    )
  (setq #pts1-slipt-1 (append (hj:cut pts1-slipt 0 (VL-POSITION pt1-slipt pts1-slipt)) (hj:cut pts1-slipt (VL-POSITION pt2-slipt pts1-slipt) (1-(length pts1-slipt))))
        #pts1-slipt-2 (hj:cut pts1-slipt (VL-POSITION pt1-slipt pts1-slipt) (VL-POSITION pt2-slipt pts1-slipt))
        )
  (list #pts1-slipt-1 #pts1-slipt-2)
  
  
  )
[/PHP]
测试一下::

[PHP](defun c:t1()
  (setq en1 (car(entsel)))
  (setq pt1 (getpoint) pt2 (getpoint))
  (setq #1 (adj:sliptPts en1 pt1 pt2))
  (mapcar '(lambda(x)(xd-mkpline x t)) #1)
  
  
  )[/PHP]
用到了一个生成多段线的函数,是从前在XDCAD上下载的,不好意思,忘记了作者.顺致谢意.
[PHP];;;给定点表,绘制多段线
;;;form xdcad.net
;;;pts 点表 tf 是否闭合
(DEFUN xd-mkpline         (pts tf)
  (ENTMAKE
    (APPEND
      '((0 . "lwpolyline")
        (100 . "AcDbEntity")
        (100 . "AcDbPolyline")
        )
      (LIST (CONS 90 (LENGTH pts)))
      (LIST (CONS 70
                  (IF tf
                    1
                    0
                    )
                  )
            )
      (MAPCAR '(LAMBDA (x) (CONS 10 (LIST (CAR x) (CADR x)))) pts)
      )
    )
  )[/PHP]
看一下效果:
c:\1.gif
对不起,居然忘记了一个函数
[PHP];;拆分表
;;从J到K的表
;;来自于highflybir mjtd.com,改了下名字,诚表谢意
(defun hj:cut (ptlist j k / i ptlist1)
  (setq i 0 ptlist1 nil)
  (foreach n ptlist
    (if (and (>= i j) (<= i k) )
      (setq ptlist1 (cons n ptlist1))
    )
    (setq i (1+ i))
  )
  (reverse ptlist1)
)

[/PHP]

Free-Lancer

少 hj:cut