树櫴希德 发表于 2019-11-22 21:11:05

2多段线延伸相交捡懒

(defun vxs(e / p a b n ob q et d d1 en et)
    (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
    (cond((="LWPOLYLINE"et)
    (repeat(length a)(setq b (nth n a) n (+ n 1))
      (if (= 10 (car b))(progn
      (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
      (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
          (setq p (list q)))))))
   ((="POLYLINE"et)
    (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
    (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
      (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
      (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
      (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
    (setq p(reverse p))))P)



;;示例(HHickSegEndPt (car(setq en(entsel))) (cadr en))


(defun HHickSegEndPt (obj p / pp n)
(setqpp (vlax-curve-getclosestpointto obj (trans p 1 0))
n(fix (vlax-curve-getparamatpoint obj pp))
)

(setq ll (length (vxs obj)));;避免最后一个点出创，加个判断(多这一句)

(list
    (vlax-curve-getPointAtParam obj n)
    (if(> (+ n 1) (- ll 1))
      (vlax-curve-getPointAtParam obj 1);;避免最后一个点出创，加个判断(多这一句)
      (vlax-curve-getPointAtParam obj (1+ n))
    )
)
)

;3、点表生成多段线
(defun makepl (lst / pt)
(entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "XDDX") (cons 90 (length lst)) (cons 70 128))
      (mapcar '(lambda (pt)(cons 10 pt)) lst ))
) )

(defun c:ed1 (/ p1 p2 j1 j2 jd a b ) ;p1 p2 j1 j2 jd

(setq p1 (entsel "\n请选择多段线需要延伸端点1：")
      p2 (entsel "\n请选择多段线需要延伸端点1：")
      )
(setq j1 (HHickSegEndPt (car p1) (cadr p1))
      j2 (HHickSegEndPt (car p2) (cadr p2))
      )
(setq jd (inters (CAR J1)(CADR J1) (CAR J2)(CADR J2) nil)
)
(setq a (vxs (car p1)   ) b (vxs (car p2)   )
)
(if (>   (distance (CAR J1) jd)(distance (CAdR J1) jd)) (setq a a) (setq a (reverse a) ) )
(if (>   (distance (CAR J2) jd)(distance (CAdR J2) jd)) (setq b (reverse b) ) (setq b b))
(makepl (append a (list jd)    b )   )
(entdel (car p1)) (entdel (car p2))
(PRINC)
)

yanshengjiang 发表于 2021-11-27 02:25:44

请问这个和cad的倒角是不是一样的

树櫴希德 发表于 2022-12-15 16:42:40



重复多段线 重复表判别 73哥函数
(defun plinexy(e / p a b n ob q et d d1 en et)
    (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
    (cond((="LWPOLYLINE"et)
    (repeat(length a)(setq b (nth n a) n (+ n 1))
      (if (= 10 (car b))(progn
      (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
      (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
          (setq p (list q)))))))
   ((="POLYLINE"et)
    (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
    (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
      (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
      (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
      (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
    (setq p(reverse p))))P)


(defun lst-(l1 l2 fuz / a l)
(while l1
      (setq a(car l1)l1(cdr l1))
      (or(vl-some(function(lambda(x)(equal a x fuz)))l2)
   (setq l(cons a l))))
      (reverse l))

(defun lst-1 (l1 l2 fuz / l)
(if l2
    (progn
      (vl-every(function(lambda(a)
      (or(vl-some(function(lambda(x)(equal a x fuz)))l2)
         (setq l(cons a l)))))l1)
      (reverse l))
    l1))

   

(setq p1(lst-(plinexy (car(entsel "\n请选择一条线："))) (plinexy (car(entsel "\n请选择另一条线："))) 0.0001 ))

树櫴希德 发表于 2019-11-23 10:51:23

(defun linezb (pp /)
(list (cdr(assoc 10 (entget pp))) (cdr(assoc 11 (entget pp))))
)

;3、点表生成多段线
(defun makepl (lst / pt)
(entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "XDDX") (cons 90 (length lst)) (cons 70 128))
      (mapcar '(lambda (pt)(cons 10 pt)) lst ))
) )

(defun c:ed2 ( / p1 p2 j1 j2 jd a b) ;p1 p2 j1 j2 jd a b

(setq p1 (entsel "\n请选择直线需要延伸端点1：")
      p2 (entsel "\n请选择直线需要延伸端点1：")
      )
(setq j1 (linezb (car p1))
      j2 (linezb (car p2))
      )
(setq jd (inters (CAR J1)(CADR J1) (CAR J2)(CADR J2) nil)
)
(setq a (linezb (car p1)   ) b (linezb (car p2)   )
)
(if (>   (distance (CAR J1) jd)(distance (CAdR J1) jd)) (setq a a) (setq a (reverse a) ) )
(if (>   (distance (CAR J2) jd)(distance (CAdR J2) jd)) (setq b (reverse b) ) (setq b b))
(makepl (append a (list jd)    b )   )
(entdel (car p1)) (entdel (car p2))
(PRINC)
)

yp9819 发表于 2020-5-7 19:48:14

老师 你好 我有个问题，想请您看看，也是关于PLINE延伸相交的问题。详细见http://bbs.mjtd.com/thread-181474-1-1.html 谢谢。相信您能解决，好吧

海尔 发表于 2020-8-7 11:12:07

海尔 发表于 2020-8-7 11:12:19

~~~~

海尔 发表于 2020-8-7 13:44:41

海尔 发表于 2020-8-7 13:44:55

999999 发表于 2020-9-10 14:11:06

支持支持，多谢楼主分享

dmxcs 发表于 2021-1-22 01:08:09

FILLET？？
页: [1] 2
查看完整版本: 2多段线延伸相交捡懒