两条线之间画等分线的代码需修正

20060510412

bai2000 发表于 2014-12-16 21:28
怎么改改，可以输入等分的个数？

要是能实现这个功能，那就太完美了

dabingrain

;;两曲线等分
(defun c:tt (/ dis L1 L2 P1 P2 A1 D1 P3 P4 A2 D2 PL1 PL2 PTS)
        (princ "\n两曲线等分：")
  (while (and
                                         (setq l1 (car (entsel "\r选择曲线1:")))
                                         (setq l2 (car (entsel "\r选择曲线2:")))
                                         (setq dis (getint "\r请输入等分份数(≥1):"))
                                 )
    (setq
                        p1  (vlax-curve-getStartPoint l1)
                        p2  (vlax-curve-getEndPoint l1)
                        d1 (* (/ 1.0 dis) (vlax-curve-getDistAtParam l1 (vlax-curve-getEndParam l1)))
                        p3  (vlax-curve-getStartPoint l2)
                        p4  (vlax-curve-getEndPoint l2)
                        d2 (* (/ 1.0 dis)  (vlax-curve-getDistAtParam l2 (vlax-curve-getEndParam l2)))
                        pl1 (list p1)
                        pl2 (list p3)
                        i 0
                )
    (repeat dis
      (setq i (1+ i)
                                pl1 (cons (vlax-curve-getpointatdist l1 (* d1 i)) pl1)
                                pl2 (cons (vlax-curve-getpointatdist l2 (* d2 i)) pl2)
                        )
                )
    (setq pl1 (cons p2 pl1)
                        pl2 (cons p4 pl2)
                )
    (if (inters (car pl1) (car pl2) (last pl1) (last pl2))
      (setq pl2 (reverse pl2))
                )
    (setq pts (mapcar 'list pl1 pl2))
    (mapcar
      '(lambda (x)
         (entmake
           (list '(0 . "line") (cons 10 (car x)) (cons 11 (cadr x)))
                                 )
                         )
      pts
                )
        )
  (princ)
)