任意曲线转多段线程序！

kozmosovia · 发表于 2025-11-4 10:49:11

ET函数可以直接获取拟合点集合，直接连接点就是模拟曲线
尽量确保曲线有一部分屏幕可见，如果曲线可见的缩放太小，误差会比较大
(acet-list-remove-adjacent-dups
(acet-geom-object-point-list
crv
(* 0.375 (acet-geom-pixel-unit))
)
)

whc880328 · 发表于 2025-11-6 19:12:45

感谢各位老师的指引

Sring65 · 发表于 2025-11-6 22:28:19

http://bbs.mjtd.com/thread-192143-1-1.html 试试这个的回复

依然小小鸟 · 发表于 2025-11-7 09:33:43

Sring65 发表于 2025-11-6 22:28
http://bbs.mjtd.com/thread-192143-1-1.html 试试这个的回复

跟我的不相关呢

依然小小鸟 · 发表于 2025-11-8 10:34:25

414249149 发表于 2025-10-17 18:09
http://bbs.mjtd.com/thread-191046-1-1.html

这个帖子里面程序的命令是啥呢我用这个命令 CESPL2PL 用不了呢

Sring65 · 发表于 2025-11-12 17:05:05

本帖最后由 Sring65 于 2025-11-12 17:06 编辑

依然小小鸟发表于 2025-11-7 09:33
跟我的不相关呢

(defun c:转化为多段线
(/ acadDoc ssg i pts ptmrg e lwPts tol entlist olst entl)
(defun *error* (msg)
(vla-endundomark acadDoc)
(if (not
(wcmatch (strcase msg t) "*break *cancel* *exit* *取消*")
)
(princ (strcat "\n运行错误: " msg))
)
(princ)
)
(defun tan (x)
(/ (sin x) (cos x))
)
(setq acadDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark acadDoc)
(setq ssg (ssget '((0 . "CIRCLE,ARC,ELLIPSE,LINE,SPLINE,*POLYLINE"))))
(setq i -1)
(while (setq e (ssname ssg (setq i (1+ i))))
(setq lwPts (转化为多段线 e))
(if (not (CheckPtLstclockwisep (mapcar 'car lwPts)))
(setq lwPts (lwplineReverse lwPts))
)
(setq pts (cons lwPts pts))
)
(setq tol 1) ;允许误差
(setq ptmrg (MergePline pts tol))
(setq entlist (mapcar 'entmakeLWPOLYLINE ptmrg))
(vla-endundomark acadDoc)
(princ)
)
(defun 转化为多段线 (e / ename lst)
(setq ename (cdr (assoc 0 (entget e))))
(setq lst
(cond ((= ename "CIRCLE") (CircleToBulgePolyline e))
((= ename "ARC") (ArcToBulgePolyline e))
((= ename "ELLIPSE") (ellipseToBulgePolyline e))
((= ename "LINE") (LineToBulgePolyline e))
((= ename "SPLINE") (SPLINEToBulgePolyline e))
((wcmatch ename "*POLYLINE") (POLYLINEToBulgePolyline e))
)
)
(if lst
(PLlstremoveRepeat lst)
)
)
(defun PLlstremoveRepeat (lst / i res p1 p2 p3 b c1 c2)
(setq i 1)
(setq p1 (car lst))
(setq p2 (cadr lst))
(while (setq p3 (nth (setq i (1+ i)) lst))
(cond ((and (= 0 (cadr p1)) (= 0 (cadr p2)))
(if (equal (getangles (car p1) (car p2) (car p3)) pi 1e-8)
nil
(setq res (appenda res p1)
p1 p2
)
)
)
((and (/= 0 (cadr p1)) (/= 0 (cadr p2)))
(setq c1 (getCircleCenterByPtsBulge
(car p1)
(car p2)
(cadr p1)
)
)
(setq c2 (getCircleCenterByPtsBulge
(car p2)
(car p3)
(cadr p2)
)
)
(if (equal c1 c2 1e-8)
(progn
(if (> (cadr p1) 0)
(setq b (getangles (car p1) c1 (car p3)))
(setq b (- (getangles (car p3) c1 (car p1))))
)
(setq p1 (Put-IndexValue p1 1 (tan (* 0.25 b))))
)
(setq res (appenda res p1)
p1 p2
)
)
)
(t
(setq res (appenda res p1)
p1 p2
)
)
)
(setq p2 p3)
)
(setq res (append res (list p1 p2)))
)
(defun Put-IndexValue (lst n va / i)
(setq i -1)
(mapcar
'(lambda (a)
(if (= n (setq i (1+ i)))
va
a
)
)
lst
)
)
(defun vlaOffsetObjs (objs len / lst)
(setq objs (ename->object objs))
(setq lst (if (= (type objs) 'LIST)
(apply
'append
(mapcar '(lambda (a)
(safearray->List (vla-Offset a len))
)
objs
)
)
(safearray->List (vla-Offset objs len))
)
)
(vl-remove-if
'null
(mapcar '(lambda (e)
(if (vlax-erased-p e)
nil
e
)
)
lst
)
)
)
(defun safearray->List (s / i lst l e)
(if (= 'variant (type s))
(setq s (vlax-variant-value s))
)
(setq i -1)
(setq l (vlax-safearray-get-u-bound s 1))
(while (<= (setq i (1+ i)) l)
(setq e (vlax-safearray-get-element s i))
(setq lst (cons e lst))
)
lst
)
(defun entmakeLWPOLYLINE (pts / e)
(setq e (entlast))
(entmake
(append
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length pts)) ; 点的数量
; 闭合标志
(if (equal (caar pts) (car (last pts)) 1e-8)
(cons 70 1)
(cons 70 0)
)
)
(apply 'append
(mapcar
'(lambda (a) ; 这里加上了单引号
(list (cons 10 (car a))
(cons 42 (cadr a))
)
) ; 每个点和 bulge
pts
)
)
)
)
(entnext e)
)
(defun CircleToBulgePolyline (ent / edata center radius
ang points bulge i pt1
pt2 points
)
(setq edata (entget ent))
(setq center (cdr (assoc 10 edata)))
(setq radius (cdr (assoc 40 edata)))
(setq bulge (tan (/ pi 4))) ; tan(45°) = 1.0
(setq points '())
(setq i 0)
(while (< i 3)
(setq pt (polar center (* i pi) radius))
(setq points (append points (list (list pt bulge))))
(setq i (1+ i))
)
points
)
(defun tan (x)
(/ (sin x) (cos x))
)
(defun POLYLINEToBulgePolyline (ent / pts p ptsOut i)
(setq pts (vl-remove-if
'null
(mapcar
'(lambda (x)
(cond ((= (car x) 10) (cdr x))
((= (car x) 42) (cdr x))
)
)
(entget ent)
)
)
)
(if (/= 'LIST (type (cadr pts)))
(progn (setq i -2)
(while (setq p (nth (setq i (+ 2 i)) pts))
(setq ptsOut (append ptsOut (list (list p (nth (1+ i) pts)))))
)
)
pts
)
)
(defun getspPolyParamlist (obj pms pme / a1 a2 a3 pmc gx)
(setq pmc (* 0.5 (+ pms pme)))
(setq gx 0.05)
(if (EQUAL pms pmc gx)
(list pms pme)
(progn
(setq a1 (angle '(0 0) (vlax-curve-getFirstDeriv obj pms)))
(setq a2 (angle '(0 0) (vlax-curve-getFirstDeriv obj pmc)))
(setq a3 (angle '(0 0) (vlax-curve-getFirstDeriv obj pme)))
(if (and (or (equal a1 a2 gx) (equal (abs (- a1 a2)) pi2 gx))
(or (equal a3 a2 gx) (equal (abs (- a2 a3)) pi2 gx))
)
(list pms pme)
(append (getspPolyParamlist obj pms pmc)
(cdr (getspPolyParamlist obj pmc pme))
)
)
)
)
)
(defun SPLINEToBulgePolyline (ent / pts p ptsOut i p1 p2 p3)
(setq pi2 (+ pi pi))
(setq mlst (getspPolyParamlist
ent
(vlax-curve-getStartParam ent)
(vlax-curve-getEndParam ent)
)
)
(setq mlst
(mapcar
'(lambda (a b)
(setq p1 (vlax-curve-getPointAtParam ent a))
(setq p2 (vlax-curve-getPointAtParam ent (* 0.5 (+ a b))))
(setq p3 (vlax-curve-getPointAtParam ent b))
(if (setq pc (LM:3pcircle p1 p2 p3))
(progn (setq a (getangles p1 pc p3))
(if (> a pi)
(setq a (- a pi pi))
)
(list p1 (tan (/ a 4)))
)
(list p1 0)
)
)
mlst
(append (cdr mlst) (list (vlax-curve-getEndParam ent)))
)
)
(if (vlax-curve-isClosed ent)
(setq mlst (append mlst (list (list (vlax-curve-getPointAtParam ent 0) 0))))
)
mlst
)
(defun LineToBulgePolyline (ent / edata s e)
(setq edata (entget ent))
(list (list (cdr (assoc 10 edata)) 0)
(list (cdr (assoc 11 edata)) 0)
)
)
(defun ArcToBulgePolyline (ent / edata startPt endPt
center radius startAng endAng bulge
segments angleDiff pts i
pt
)
(setq edata (entget ent))
;; 获取弧线的起点、终点、圆心、半径、角度
(setq center (cdr (assoc 10 edata))) ; 圆心
(setq radius (cdr (assoc 40 edata))) ; 半径
(setq startAng (cdr (assoc 50 edata))) ; 起始角度
(setq endAng (cdr (assoc 51 edata))) ; 结束角度
(setq angleDiff (if (< endAng startAng)
(- (+ endAng (* 2 pi)) startAng)
(- endAng startAng)
)
)
(setq bulge (tan (/ angleDiff 4)))
(list (list (polar center startAng radius) bulge)
(list (polar center endAng radius) bulge)
)
)
(defun ellipseToBulgePolyline (ent / isMirr edata center
ang a b s e
n theta delta points i
pts isMirr
)
(setq edata (entget ent))
;; 获取弧线的起点、终点、圆心、半径、角度
(setq center (cdr (assoc 10 edata))) ; 圆心
(setq ang (angle '(0 0 0) (cdr (assoc 11 edata)))) ;旋转角度
(setq a (distance '(0 0 0) (cdr (assoc 11 edata)))) ; 半径
(setq b (* a (cdr (assoc 40 edata))))
(setq s (cdr (assoc 41 edata))) ; 起始角度
(setq e (cdr (assoc 42 edata))) ; 结束角度
(setq n 64)
(setq isMirr (< (caddr (cdr (assoc 210 edata))) 0.0))
(if (> s e)
(setq e (+ e pi pi))
)
(setq theta 0) ; 初始化角度
(setq delta (/ (* 2 pi) n)) ; 计算每个增量的角度
(setq points '()) ; 存储点的列表
(setq
points (cons (list (list (* a (cos s)) (* b (sin s))) s) points)
)
; 将点添加到列表
(setq i -1)
(while (< (setq i (1+ i)) n)
(if (> theta s)
(setq points
(cons (list (list (* a (cos theta)) (* b (sin theta))) theta)
points
)
) ; 将点添加到列表
) ; 增加角度
(if (> (setq theta (+ theta delta)) e)
(setq i n)
)
)
(setq
points (cons (list (list (* a (cos e)) (* b (sin e))) e) points)
)
; 将点添加到列表
(mapcar
'(lambda (x y) ; 这里加上了单引号
(list (ellipsePointRotate '(0 0) center (car x) ang isMirr)
(if isMirr
(- (get-ellipse-Bulge a b y x))
(get-ellipse-Bulge a b y x)
)
)
) ; 每个点和 bulge
points
(append (cdr points) (list (car points)))
)
)
;;;判断椭圆是否镜像
(defun is-ellipse-mirrored (ent)
(if (and ent (= (cdr (assoc 0 (entget ent))) "ELLIPSE"))
(if (< (caddr (cdr (assoc 210 (entget ent)))) 0.0) ; Z方向为负
T ; 是镜像的
nil ; 不是镜像的
)
)
)
;;;判断是否顺时针
(defun CheckPtLstclockwisep (lst / l2)
(defun calo2A (i j)
(- (* (car i) (cadr j)) (* (car j) (cadr i)))
)
(setq l2 (append (cdr lst) (list (car lst))))
(< (apply '+ (mapcar 'calo2A lst l2)) 1e-8)
)
(defun get-ellipse-Bulge (a b x y / c p0 s e pc)
(setq c (* 0.5 (+ (cadr y) (cadr x))))
(setq pc (list (* a (cos c)) (* b (sin c))))
(if (setq p0 (LM:3pcircle (car x) pc (car y)))
(progn
(setq s (angle p0 (car x)))
(setq e (angle p0 (car y)))
(if (< e s)
(setq e (+ e pi pi))
)
(tan (* -0.25 (- e s)))
)
0
)
)
(defun ellipsePointRotate (p1 P2 Pm ang isMirr / a)
(if isMirr
(setq a (- ang (angle p1 pm)))
(setq a (+ ang (angle p1 pm)))
)
(mapcar '+ p2 (polar p1 a (distance p1 pm)))
)
(defun LM:3pcircle (pt1 pt2 pt3 / a b c d)
(setq pt2 (mapcar '- pt2 pt1)
pt3 (mapcar '- pt3 pt1)
a (* 2.0
(- (* (car pt2) (cadr pt3)) (* (cadr pt2) (car pt3)))
)
b (distance '(0.0 0.0) pt2)
c (distance '(0.0 0.0) pt3)
b (* b b)
c (* c c)
)
(if (/= a 0)
(mapcar '+
pt1
(list
(/ (- (* (cadr pt3) b) (* (cadr pt2) c)) a)
(/ (- (* (car pt2) c) (* (car pt3) b)) a)
0
)
)
)
)
(defun sortByAngle-i (pt0 pt1 ptxlst / angb anga ang0)
(vl-sort-i ptxlst
'(lambda (a b)
(< (getAngles pt0 pt1 a) (getAngles pt0 pt1 b))
)
)
)
(defun sortByAngle (pt0 pt1 ptxlst / angb anga ang0)
(vl-sort ptxlst
'(lambda (a b)
(< (getAngles pt0 pt1 a) (getAngles pt0 pt1 b))
)
)
)
(defun sortByDistance (p ptxlst)
(vl-sort ptxlst
'(lambda (a b) (< (distance p a) (distance p b)))
)
)
(defun sortByDistance-i (p ptxlst)
(vl-sort-i ptxlst
'(lambda (a b) (< (distance p a) (distance p b)))
)
)
;;;中心点
(defun getPtsCenter (pts / l _f)
(setq l (length pts))
(defun _f (a) (/ a l))
(setq pts (apply 'mapcar (cons '+ pts)))
(mapcar '_f pts)
)
(defun MergePline (all-lines tol / n1 rs)
(while all-lines
(setq n1 (car all-lines))
(setq all-lines (cdr all-lines))
(setq rs (cons (MergePlineNear n1 tol) rs))
)
rs
)
(defun MergeOutPline (all-lines tol / n1 rs r1 r2 pts ps si tmp)
(if all-lines
(progn
(setq pts (mapcar '(lambda (a) (mapcar 'car a)) all-lines))
(setq pts (mapcar 'getPtsCenter pts))
(setq ptn (mapcar '- (apply 'mapcar (cons 'min pts)) '(1 1 1)))
(setq si (sortByDistance-i ptn pts))
(setq n1 (nth (car si) all-lines))
(setq all-lines (vl-remove n1 all-lines))
(setq tmp all-lines)
(setq r1 (list (MergePlineNear n1 tol)))
(setq all-lines tmp)
(setq r2 (list (MergePlineNear (lwplineReverse n1) tol)))
(if (> (length (car r2)) (length (car r1)))
r2
r1
)
)
)
)
(defun getPtNth2 (s r / p ret)
(if r
(setq s (reverse s))
)
(setq p (caar s))
(setq ret (caar (setq s (cdr s))))
(while (and (equals p ret 1e-6)
(setq s (cdr s))
)
(setq ret (caar s))
)
ret
)
;;查找点附近的
(defun MergeNextPtNear
(lst p0 ps tol clk-p / d x l res pts i n1 n0
chklp ptmin ptn)
(setq d tol)
(mapcar
'(lambda (x)
(setq l (distance ps (caar x)))
(if (and (< l tol) (or (< l d) (equal d l 1e-6)))
(if (equal d l 1e-6)
(setq res (cons (list x nil) res)
pts (cons (getPtNth2 x nil) pts)
)
(setq d l
res (list (list x nil))
pts (list (getPtNth2 x nil))
)
)
)
(setq l (distance ps (car (last x))))
(if (and (< l tol) (or (< l d) (equal d l 1e-6)))
(if (equal d l 1e-6)
(setq res (cons (list x t) res)
pts (cons (getPtNth2 x t) pts)
)
(setq d l
res (list (list x t))
pts (list (getPtNth2 x t))
)
)
)
)
lst
)
(if (> (length pts) 1)
(progn
(setq ptsr (sortByAngle-i p0 ps pts))
(if clk-p
(setq res (nth (last ptsr) res))
(setq res (nth (car ptsr) res))
)
)
(setq res (car res))
)
res ;返回相邻列表，和是否反向
)
;;;查找相邻
(defun MergePlineNear
(frst tol / res _f r lastf chkpt ptsr clk-p p rList)
(defun _f (ps / res)
(if (setq res (MergeNextPtNear all-lines chkpt ps tol clk-p))
(progn
(setq all-lines (vl-remove (car res) all-lines))
(if (cadr res)
(lwplineReverse (car res))
(car res)
)
)
)
)
(while (and
(setq p (caar frst))
(not (member p rList))
(not (< (distance p (car (last frst))) tol))
(setq chkpt (getPtNth2 frst nil))
(setq r (_f p))
) ;检查起点
(setq rList (cons p rList))
(if (equals (caar r) p 1e-6)
(setq r (lwplineReverse r)
r (vl-remove (last r) r)
)
(setq r (lwplineReverse r))
)
(setq frst (append r frst))
)
(setq clk-p t)
(while (and
(setq p (car (last frst)))
(not (member p rList))
(not (< (distance (caar frst) p) tol))
(setq chkpt (getPtNth2 frst t))
(setq r (_f p))
) ;检查终点位置
(setq rList (cons p rList))
(if (equals (caar r) p 1e-6)
(setq frst (vl-remove (last frst) frst))
)
(setq frst (append frst r))
)
(if (and (< (distance (caar frst) (car (last frst))) tol)
(not (equal (caar frst) (car (last frst)) 1e-6))
)
(setq frst (cons (last frst) frst))
)
frst
)
(defun lwplineReverse (pts)
(setq pts (Reverse pts))
(mapcar
'(lambda (a b) (list (car a) (- (cadr b))))
pts
(append (cdr pts) (list (car pts)))
)
)
;;;三维点集转点集合
(defun Arr3dToPtlst (tmp / lst)
(while tmp
(setq lst (appenda lst (list (car tmp) (cadr tmp) (caddr tmp)))
tmp (cdddr tmp)
)
)
lst
)
(defun Arr2dToPtlst (tmp / lst)
(while tmp
(setq lst (appenda lst (list (car tmp) (cadr tmp) 0))
tmp (cddr tmp)
)
)
lst
)
(defun getCircleCenterByPtsBulge (pt1 pt2 bulge / ptc x1 x2 y1 y2 b)
(setq x1 (car pt1)
y1 (cadr pt1)
x2 (car pt2)
y2 (cadr pt2)
b (* 0.5 (- (/ 1 bulge) bulge))
ptc (list (* 0.5 (+ x1 x2 (- (* b (- y2 y1)))))
(* 0.5 (+ y1 y2 (* b (- x2 x1))))
0
)
)
)
(defun getAngles (pt1 pt2 pt3 / ang a1 a2)
(if (or (equal pt2 pt1 1e-6) (equal pt2 pt3 1e-6))
(+ pi pi)
(progn
(setq ang (- (Angle pt2 pt3) (Angle pt2 pt1)))
(if (< ang 0)
(setq ang (+ ang pi pi))
)
(if (equal ang 0 1e-6)
(+ pi pi)
ang
)
)
)
)
(defun Equals (a b p)
(vl-every '(lambda (x y) (equal x y p)) a b)
)
(defun checkPtInArc (ptx ptCircleCenter p1 p2 / r x angx ang1 ang2)
(if (not (And (Equals p1 p2 1e-6) (Equals ptx p2)))
(progn
(setq r (Distance ptx ptCircleCenter))
(setq x (Distance p1 ptCircleCenter))
(If (Equal r x 1e-6)
(progn
(setq angx (getAngles p1 ptCircleCenter ptx)
ang1 (getAngles p1 ptCircleCenter p2)
)
(if (> ang1 angx)
t
nil
)
)
)
)
)
)
(defun checkPtInPtlst (pt pts)
(equal (getangles (car pts) pt (cadr pts)) pi 1e-6)
)
(defun ArraySort (sortIdx lst)
(mapcar '(lambda (n) (nth n lst)) (VL-SORT-I sortIdx '<))
)
(defun BulgeFromArc (ps pe pc bulge / a)
(setq a (getangles ps pc pe))
(if (> bulge 0)
(tan (* 0.25 a))
(tan (* 0.25 (- a pi pi)))
)
)
(defun set3dPtZBy2Pt (pt ptr pte / le lt zr ze z)
(setq zr (caddr ptr)
ze (caddr pte)
)
(if (and (= zr 0) (= 0 pte))
(list (car pt) (cadr pt) 0)
(progn
(setq le (Distance ptr pte)
lt (Distance ptr pt)
)
(If (/= le 0)
(setq z (- zr (* lt (/ (- zr ze) le))))
(setq z zr)
)
(list (car pt) (cadr pt) z)
)
)
)
(defun getPLCenterPt (pt1 pt2 b / pt)
(setq pt (mapcar '* '(0.5 0.5 0.5) (mapcar '+ pt1 pt2)))
(If (Equals pt pt1 1e-6)
pt
(Polar pt
(- (Angle pt1 pt2) (* 0.5 pi))
(* (Distance pt1 pt2) 0.5 b)
)
)
)
(defun appenda (lst a)
(append lst (list a))
)
(defun ptTo3D (pt)
(if (= (type (car pt)) 'LIST)
(mapcar 'ptTo3D pt)
(if (car pt)
(list (car pt)
(cadr pt)
(if (caddr pt)
(caddr pt)
0
)
)
nil
)
)
)
(defun ptTo2D (pt)
(if (= (type pt) 'LIST)
(if (= (type (car pt)) 'LIST)
(mapcar 'ptTo2D pt)
(list (car pt) (cadr pt))
)
(progn pt)
)
)
(defun Plpts2DToArr (pts / l points)
(setq pts (apply 'append (mapcar 'ptto2d pts)))
(setq l (cons 0 (1- (length pts))))
(setq points (vlax-make-safearray vlax-vbDouble l))
(vlax-safearray-fill points pts)
)
(defun Plpts3DToArr (pts / l points)
(setq pts (apply 'append (mapcar 'ptto3d pts)))
(setq l (cons 0 (1- (length pts))))
(setq points (vlax-make-safearray vlax-vbDouble l))
(vlax-safearray-fill points pts)
)
(defun ename->object (s / e lst i _f)
(defun _f (e)
(if (= 'ENAME (type e))
(vlax-ename->vla-object e)
e
)
)
(setq i -1)
(if (= (type s) 'PICKSET)
(while (setq e (ssname s (setq i (1+ i))))
(setq lst (cons (_f e) lst))
)
(if (= (type s) 'LIST)
(mapcar 'ename->object s)
(_f s)
)
)
)
(defun cutPolylineByObjs (ssg / i j tmp e f ptsArr objlst)
(setq i -1)
(setq objlst (ename->object ssg))
(setq i -1)
(while (setq e (nth (setq i (1+ i)) objlst))
(setq j i)
(while (setq f (nth (setq j (1+ j)) objlst))
(if (setq tmp (vlax-invoke e 'intersectwith f acextendnone))
(setq ptsArr (append ptsArr tmp))
)
)
)
(if (> (Length ptsArr) 0)
(progn
(setq ptsArr (Arr3dToPtlst ptsArr))
(apply 'append
(mapcar '(lambda (e) (cutPolyline e ptsArr))
objlst
)
)
)
)
)
(defun cutPolyline (obj breakPtlst / ptsArr
jn EntityName StartWidth i
j L Crdnj Crdn
notDeleteObj ptxbulge flg_Bg
ix ptIx flg_Wd ib
Ent plineLength ptxEndbulge
widthxS widthxE EndWidth widthx
ptxLst distAng ang12 ptxLstDist
isInArc ptCircleCenter bulge
cpobj p1 p2 ptr
pte ptx ptc Coordinates
newCrdnt Crdnt0 CrdntLst bulgeLst
newBulges widthLst newWidths dpz
tmp bCadCutCheckIn CrdnCar
)
(setq obj (ename->object obj))
(if (> (Length breakPtlst))
(progn
(setq ptsArr breakPtlst)
(setq EntityName
(vla-get-ObjectName obj)
)
(if (= EntityName "AcDbPolyline")
(setq Coordinates (Arr2dToPtlst (vlax-get obj 'Coordinates)))
(setq Coordinates (Arr3dToPtlst (vlax-get obj 'Coordinates)))
)
(setq jn 0)
(If (= (vla-get-closed obj) :vlax-true)
(if (not (Equal (car Coordinates)
(last Coordinates)
1e-6
)
)
(setq Coordinates
(append Coordinates (list (car Coordinates)))
)
)
(setq ptr (car Coordinates)
pte (last Coordinates)
)
)
(setq i -1)
(while (and (setq p1 (nth (setq i (1+ i)) Coordinates))
(setq p2 (nth (1+ i) Coordinates))
)
(If (not (Equal p1 p2 1e-6))
(progn
(setq bulge (vla-GetBulge obj i))
(vla-GetWidth obj i 'StartWidth 'EndWidth)
(If (/= StartWidth EndWidth)
(setq flg_Wd t)
)
(If (/= bulge 0)
(progn
(setq flg_Bg t)
(setq ptCircleCenter
(getCircleCenterByPtsBulge p1 p2 bulge)
)
(setq j (1- jn))
;;检查每个交点是否在多段线节点线段上
(while (setq ptx (nth (setq j (1+ j)) ptsArr))
(If (> bulge 0)
(setq
isInArc (checkPtInArc ptx ptCircleCenter p1 p2)
)
(setq
isInArc (checkPtInArc ptx ptCircleCenter p2 p1)
)
)
;判断交点是否在弧线段上
(If (and isInArc (not (Equals ptx p1 1e-6)))
(progn
(setq ptxLst (append ptxLst (list ptx)))
(if (> bulge 0)
(setq distAng (getAngles p1 ptCircleCenter ptx)
ang12 (getAngles p1 ptCircleCenter p2)
)
(setq distAng (getAngles ptx ptCircleCenter p1)
ang12 (getAngles p2 ptCircleCenter p1)
)
)
(setq tmp (/ distAng ang12))
(setq ptxLstDist (appenda ptxLstDist tmp))
)
)
)
)
(progn
(setq j (1- jn)) ;检查每个交点是否在多段线节点线段上
(while (setq ptx (nth (setq j (1+ j)) ptsArr))
(If (checkPtInPtlst ptx (list p1 p2))
;判断交点是否在线段上
(setq ptxLst (appenda ptxLst ptx)
dpz (/ (Distance p1 ptx) (Distance p1 p2))
ptxLstDist (appenda ptxLstDist dpz)
)
)
)
)
)
(If (> (Length ptxLst) 0) ;是否存在交点
(progn
(setq ptxLst (ArraySort ptxLstDist ptxLst))
(If
(and (= bulge 0)
(= StartWidth EndWidth)
)
(progn
(setq tmp (list p1 bulge StartWidth EndWidth))
(setq newCrdnt (appenda newCrdnt tmp))
(ForEach ptx ptxLst
(setq tmp (list ptx bulge StartWidth EndWidth))
(setq newCrdnt (appenda newCrdnt tmp))
(setq CrdntLst (appenda CrdntLst newCrdnt))
(setq tmp (list ptx bulge StartWidth EndWidth))
(setq newCrdnt (list tmp))
)
)
(progn
(setq ptxEndbulge
0
ptxbulge 0
widthxS StartWidth
ptx p1
ix -1
)
(while (setq ptIx (nth (setq ix (1+ ix)) ptxLst))
(setq ptxbulge
(BulgeFromArc
ptx
ptIx
ptCircleCenter
bulge
)
)
(setq
widthxE
(- StartWidth
(* (nth ix ptxLstDist)
(- StartWidth EndWidth)
)
)
)
(setq tmp (list ptx ptxbulge widthxS widthxE))
(setq newCrdnt (appenda newCrdnt tmp))
;存入作为起点
(setq ptx ptIx)
(If (= EntityName "AcDb2DPolyline")
(setq ptx (set3dPtZBy2Pt ptx p1 p2))
)
(setq tmp (list ptx 0 0 0))
(setq newCrdnt (appenda newCrdnt tmp))
;交点存入作为终点
(setq CrdntLst (appenda CrdntLst newCrdnt))
(Setq newCrdnt nil)
(setq widthxS widthxE)
(setq ptxbulge
(BulgeFromArc
ptx
p2
ptCircleCenter
bulge
)
)
(setq tmp (list ptx ptxbulge widthxS EndWidth))
(setq newCrdnt (appenda newCrdnt tmp))
;px存入作为起点
)
)
)
(Setq ptxLstDist nil)
(Setq ptxLst nil)
)
(setq tmp (list p1 bulge StartWidth EndWidth)
newCrdnt (appenda newCrdnt tmp)
) ;将点1存如数组
)
)
)
)
;;多段线判断结束
(If (> (Length CrdntLst) 0)
(progn
(if (= (vla-get-closed obj) :vlax-true)
;判断闭合保持闭合线收尾相连
(setq CrdntLst
(cons (append newCrdnt (car CrdntLst))
(cdr CrdntLst)
)
)
(setq tmp (list pte 0 0 0) ;添加末尾点
newCrdnt (appenda newCrdnt tmp)
CrdntLst (appenda CrdntLst newCrdnt)
)
)
CrdntLst
)
)
)
)
)

(defun c:转化为多段线 
       (/ acadDoc ssg i pts ptmrg e lwPts tol entlist olst entl) 
  (defun *error* (msg) 
    (vla-endundomark acadDoc) 
    (if        (not 
          (wcmatch (strcase msg t) "*break *cancel* *exit* *取消*") 
        ) 
      (princ (strcat "\n运行错误: " msg)) 
    ) 
    (princ) 
  ) 
  (defun tan (x) 
    (/ (sin x) (cos x)) 
  ) 
  (setq acadDoc (vla-get-ActiveDocument (vlax-get-acad-object))) 
  (vla-StartUndoMark acadDoc) 
  (setq ssg (ssget '((0 . "CIRCLE,ARC,ELLIPSE,LINE,SPLINE,*POLYLINE")))) 
  (setq i -1) 
  (while (setq e (ssname ssg (setq i (1+ i)))) 
    (setq lwPts (转化为多段线 e)) 
    (if        (not (CheckPtLstclockwisep (mapcar 'car lwPts))) 
      (setq lwPts (lwplineReverse lwPts)) 
    ) 
    (setq pts (cons lwPts pts)) 
  ) 
  (setq tol 1)                                ;允许误差 
  (setq ptmrg (MergePline pts tol))   
  (setq entlist (mapcar 'entmakeLWPOLYLINE ptmrg)) 
  (vla-endundomark acadDoc) 
  (princ) 
) 
(defun 转化为多段线 (e / ename lst) 
  (setq ename (cdr (assoc 0 (entget e)))) 
  (setq        lst 
         (cond ((= ename "CIRCLE") (CircleToBulgePolyline e)) 
               ((= ename "ARC") (ArcToBulgePolyline e)) 
               ((= ename "ELLIPSE") (ellipseToBulgePolyline e)) 
               ((= ename "LINE") (LineToBulgePolyline e)) 
               ((= ename "SPLINE") (SPLINEToBulgePolyline e)) 
               ((wcmatch ename "*POLYLINE") (POLYLINEToBulgePolyline e)) 
         ) 
  ) 
  (if lst 
    (PLlstremoveRepeat lst) 
  ) 
) 
  (defun PLlstremoveRepeat (lst / i res p1 p2 p3 b c1 c2) 
    (setq i 1) 
    (setq p1 (car lst)) 
    (setq p2 (cadr lst)) 
    (while (setq p3 (nth (setq i (1+ i)) lst)) 
      (cond ((and (= 0 (cadr p1)) (= 0 (cadr p2))) 
             (if (equal (getangles (car p1) (car p2) (car p3)) pi 1e-8) 
               nil 
               (setq res (appenda res p1) 
                     p1         p2 
               ) 
             ) 
            ) 
            ((and (/= 0 (cadr p1)) (/= 0 (cadr p2))) 
              (setq c1 (getCircleCenterByPtsBulge 
                         (car p1) 
                         (car p2) 
                         (cadr p1) 
                       ) 
              ) 
              (setq c2 (getCircleCenterByPtsBulge 
                         (car p2) 
                         (car p3) 
                         (cadr p2) 
                       ) 
              ) 
              (if (equal c1 c2 1e-8) 
                (progn 
                  (if (> (cadr p1) 0) 
                    (setq b (getangles (car p1) c1 (car p3))) 
                    (setq b (- (getangles (car p3) c1 (car p1)))) 
                  ) 
                  (setq p1 (Put-IndexValue p1 1 (tan (* 0.25 b)))) 
                ) 
                (setq res (appenda res p1) 
                      p1  p2 
                ) 
              ) 
            ) 
            (t 
             (setq res (appenda res p1) 
                   p1  p2 
             ) 
            ) 
      ) 
      (setq p2 p3) 
    ) 
    (setq res (append res (list p1 p2))) 
  ) 
 
(defun Put-IndexValue (lst n va / i) 
  (setq i -1) 
  (mapcar 
    '(lambda (a) 
       (if (= n (setq i (1+ i))) 
         va 
         a 
       ) 
     ) 
    lst 
  ) 
) 
(defun vlaOffsetObjs (objs len / lst) 
  (setq objs (ename->object objs)) 
  (setq        lst (if        (= (type objs) 'LIST) 
              (apply 
                'append 
                (mapcar        '(lambda (a) 
                           (safearray->List (vla-Offset a len)) 
                         ) 
                        objs 
                ) 
              ) 
              (safearray->List (vla-Offset objs len)) 
            ) 
  ) 
  (vl-remove-if 
    'null 
    (mapcar '(lambda (e) 
               (if (vlax-erased-p e) 
                 nil 
                 e 
               ) 
             ) 
            lst 
    ) 
  ) 
) 
(defun safearray->List (s / i lst l e) 
  (if (= 'variant (type s)) 
    (setq s (vlax-variant-value s)) 
  ) 
  (setq i -1) 
  (setq l (vlax-safearray-get-u-bound s 1)) 
  (while (<= (setq i (1+ i)) l) 
    (setq e (vlax-safearray-get-element s i)) 
    (setq lst (cons e lst)) 
  ) 
  lst 
) 
(defun entmakeLWPOLYLINE (pts / e) 
  (setq e (entlast)) 
  (entmake 
    (append 
      (list 
        '(0 . "LWPOLYLINE") 
        '(100 . "AcDbEntity") 
        '(100 . "AcDbPolyline") 
        (cons 90 (length pts))                ; 点的数量 
                                        ; 闭合标志 
        (if (equal (caar pts) (car (last pts)) 1e-8) 
          (cons 70 1) 
          (cons 70 0) 
        ) 
      ) 
      (apply 'append 
             (mapcar 
               '(lambda        (a)                ; 这里加上了单引号 
                  (list        (cons 10 (car a)) 
                        (cons 42 (cadr a)) 
                  ) 
                )                        ; 每个点和 bulge 
               pts 
             ) 
      ) 
    ) 
  ) 
  (entnext e) 
) 
(defun CircleToBulgePolyline (ent     /              edata   center  radius 
                              ang     points  bulge   i              pt1 
                              pt2     points 
                             ) 
  (setq edata (entget ent)) 
  (setq center (cdr (assoc 10 edata))) 
  (setq radius (cdr (assoc 40 edata))) 
  (setq bulge (tan (/ pi 4)))                ; tan(45°) = 1.0 
  (setq points '()) 
  (setq i 0) 
  (while (
    (setq pt (polar center (* i pi) radius)) 
    (setq points (append points (list (list pt bulge)))) 
    (setq i (1+ i)) 
  ) 
  points 
) 
(defun tan (x) 
  (/ (sin x) (cos x)) 
) 
(defun POLYLINEToBulgePolyline (ent / pts p ptsOut i) 
  (setq        pts (vl-remove-if 
              'null 
              (mapcar 
                '(lambda (x) 
                   (cond ((= (car x) 10) (cdr x)) 
                         ((= (car x) 42) (cdr x)) 
                   ) 
                 ) 
                (entget ent) 
              ) 
            ) 
  ) 
  (if (/= 'LIST (type (cadr pts))) 
    (progn (setq i -2) 
           (while (setq p (nth (setq i (+ 2 i)) pts)) 
             (setq ptsOut (append ptsOut (list (list p (nth (1+ i) pts))))) 
           ) 
    ) 
    pts 
  ) 
) 
(defun getspPolyParamlist (obj pms pme / a1 a2 a3 pmc gx) 
  (setq pmc (* 0.5 (+ pms pme))) 
  (setq gx 0.05) 
  (if (EQUAL pms pmc gx) 
    (list pms pme) 
    (progn 
      (setq a1 (angle '(0 0) (vlax-curve-getFirstDeriv obj pms))) 
      (setq a2 (angle '(0 0) (vlax-curve-getFirstDeriv obj pmc))) 
      (setq a3 (angle '(0 0) (vlax-curve-getFirstDeriv obj pme))) 
      (if (and (or (equal a1 a2 gx) (equal (abs (- a1 a2)) pi2 gx)) 
               (or (equal a3 a2 gx) (equal (abs (- a2 a3)) pi2 gx)) 
          ) 
        (list pms pme) 
        (append        (getspPolyParamlist obj pms pmc) 
                (cdr (getspPolyParamlist obj pmc pme)) 
        ) 
      ) 
    ) 
  ) 
) 
(defun SPLINEToBulgePolyline (ent / pts p ptsOut i p1 p2 p3) 
  (setq pi2 (+ pi pi)) 
  (setq        mlst (getspPolyParamlist 
               ent 
               (vlax-curve-getStartParam ent) 
               (vlax-curve-getEndParam ent) 
             ) 
  ) 
  (setq        mlst 
         (mapcar 
           '(lambda (a b) 
              (setq p1 (vlax-curve-getPointAtParam ent a)) 
              (setq p2 (vlax-curve-getPointAtParam ent (* 0.5 (+ a b)))) 
              (setq p3 (vlax-curve-getPointAtParam ent b)) 
              (if (setq pc (LM:3pcircle p1 p2 p3)) 
                (progn (setq a (getangles p1 pc p3)) 
                       (if (> a pi) 
                         (setq a (- a pi pi)) 
                       ) 
                       (list p1 (tan (/ a 4))) 
                ) 
                (list p1 0) 
              ) 
            ) 
           mlst 
           (append (cdr mlst) (list (vlax-curve-getEndParam ent))) 
         ) 
  )   
  (if (vlax-curve-isClosed ent) 
    (setq mlst (append mlst (list (list (vlax-curve-getPointAtParam ent 0) 0)))) 
  ) 
  mlst 
) 
(defun LineToBulgePolyline (ent / edata s e) 
  (setq edata (entget ent)) 
  (list        (list (cdr (assoc 10 edata)) 0) 
        (list (cdr (assoc 11 edata)) 0) 
  ) 
) 
(defun ArcToBulgePolyline (ent            /             edata    startPt  endPt 
                           center   radius   startAng endAng   bulge 
                           segments angleDiff              pts      i 
                           pt 
                          ) 
  (setq edata (entget ent)) 
  ;; 获取弧线的起点、终点、圆心、半径、角度 
  (setq center (cdr (assoc 10 edata)))        ; 圆心 
  (setq radius (cdr (assoc 40 edata)))        ; 半径 
  (setq startAng (cdr (assoc 50 edata))) ; 起始角度 
  (setq endAng (cdr (assoc 51 edata)))        ; 结束角度 
 
 
  (setq        angleDiff (if (< endAng startAng) 
                    (- (+ endAng (* 2 pi)) startAng) 
                    (- endAng startAng) 
                  ) 
  ) 
  (setq bulge (tan (/ angleDiff 4))) 
  (list        (list (polar center startAng radius) bulge) 
        (list (polar center endAng radius) bulge) 
  ) 
) 
(defun ellipseToBulgePolyline (ent    /             isMirr edata  center 
                               ang    a             b            s           e 
                               n      theta  delta  points i 
                               pts    isMirr 
                              ) 
  (setq edata (entget ent)) 
  ;; 获取弧线的起点、终点、圆心、半径、角度 
  (setq center (cdr (assoc 10 edata)))        ; 圆心 
  (setq ang (angle '(0 0 0) (cdr (assoc 11 edata)))) ;旋转角度 
  (setq a (distance '(0 0 0) (cdr (assoc 11 edata)))) ; 半径 
  (setq b (* a (cdr (assoc 40 edata)))) 
  (setq s (cdr (assoc 41 edata)))        ; 起始角度 
  (setq e (cdr (assoc 42 edata)))        ; 结束角度 
  (setq n 64) 
  (setq isMirr (< (caddr (cdr (assoc 210 edata))) 0.0)) 
  (if (> s e) 
    (setq e (+ e pi pi)) 
  ) 
  (setq theta 0)                        ; 初始化角度 
  (setq delta (/ (* 2 pi) n))                ; 计算每个增量的角度 
  (setq points '())                        ; 存储点的列表 
  (setq 
    points (cons (list (list (* a (cos s)) (* b (sin s))) s) points) 
  ) 
                                        ; 将点添加到列表 
  (setq i -1) 
  (while (< (setq i (1+ i)) n) 
    (if        (> theta s) 
      (setq points 
             (cons (list (list (* a (cos theta)) (* b (sin theta))) theta) 
                   points 
             ) 
      )                                        ; 将点添加到列表 
    )                                        ; 增加角度 
    (if        (> (setq theta (+ theta delta)) e) 
      (setq i n) 
    ) 
  ) 
  (setq 
    points (cons (list (list (* a (cos e)) (* b (sin e))) e) points) 
  ) 
                                        ; 将点添加到列表 
  (mapcar 
    '(lambda (x y)                        ; 这里加上了单引号 
       (list (ellipsePointRotate '(0 0) center (car x) ang isMirr) 
             (if isMirr 
               (- (get-ellipse-Bulge a b y x)) 
               (get-ellipse-Bulge a b y x) 
             ) 
       ) 
     )                                        ; 每个点和 bulge 
    points 
    (append (cdr points) (list (car points))) 
  ) 
) 
;;;判断椭圆是否镜像 
(defun is-ellipse-mirrored (ent) 
  (if (and ent (= (cdr (assoc 0 (entget ent))) "ELLIPSE")) 
    (if        (< (caddr (cdr (assoc 210 (entget ent)))) 0.0) ; Z方向为负 
      T                                        ; 是镜像的 
      nil                                ; 不是镜像的 
    ) 
  ) 
) 
;;;判断是否顺时针 
(defun CheckPtLstclockwisep (lst / l2) 
  (defun calo2A        (i j) 
    (- (* (car i) (cadr j)) (* (car j) (cadr i))) 
  ) 
  (setq l2 (append (cdr lst) (list (car lst)))) 
  (< (apply '+ (mapcar 'calo2A lst l2)) 1e-8) 
) 
 
(defun get-ellipse-Bulge (a b x y / c p0 s e pc) 
  (setq c (* 0.5 (+ (cadr y) (cadr x)))) 
  (setq pc (list (* a (cos c)) (* b (sin c)))) 
  (if (setq p0 (LM:3pcircle (car x) pc (car y))) 
    (progn 
      (setq s (angle p0 (car x))) 
      (setq e (angle p0 (car y))) 
      (if (< e s) 
        (setq e (+ e pi pi)) 
      ) 
      (tan (* -0.25 (- e s))) 
    ) 
    0 
  ) 
) 
(defun ellipsePointRotate (p1 P2 Pm ang isMirr / a) 
  (if isMirr 
    (setq a (- ang (angle p1 pm))) 
    (setq a (+ ang (angle p1 pm))) 
  ) 
  (mapcar '+ p2 (polar p1 a (distance p1 pm))) 
) 
(defun LM:3pcircle (pt1 pt2 pt3 / a b c d) 
  (setq        pt2 (mapcar '- pt2 pt1) 
        pt3 (mapcar '- pt3 pt1) 
        a   (* 2.0 
               (- (* (car pt2) (cadr pt3)) (* (cadr pt2) (car pt3))) 
            ) 
        b   (distance '(0.0 0.0) pt2) 
        c   (distance '(0.0 0.0) pt3) 
        b   (* b b) 
        c   (* c c) 
  ) 
  (if (/= a 0) 
    (mapcar '+ 
            pt1 
            (list 
              (/ (- (* (cadr pt3) b) (* (cadr pt2) c)) a) 
              (/ (- (* (car pt2) c) (* (car pt3) b)) a) 
              0 
            ) 
    ) 
  ) 
) 
(defun sortByAngle-i (pt0 pt1 ptxlst / angb anga ang0) 
  (vl-sort-i ptxlst 
             '(lambda (a b) 
                (< (getAngles pt0 pt1 a) (getAngles pt0 pt1 b)) 
              ) 
  ) 
) 
(defun sortByAngle (pt0 pt1 ptxlst / angb anga ang0) 
  (vl-sort ptxlst 
           '(lambda (a b) 
              (< (getAngles pt0 pt1 a) (getAngles pt0 pt1 b)) 
            ) 
  ) 
) 
(defun sortByDistance (p ptxlst) 
  (vl-sort ptxlst 
           '(lambda (a b) (< (distance p a) (distance p b))) 
  ) 
) 
(defun sortByDistance-i        (p ptxlst) 
  (vl-sort-i ptxlst 
             '(lambda (a b) (< (distance p a) (distance p b))) 
  ) 
) 
;;;中心点 
(defun getPtsCenter (pts / l _f) 
  (setq l (length pts)) 
  (defun _f (a) (/ a l)) 
  (setq pts (apply 'mapcar (cons '+ pts))) 
  (mapcar '_f pts) 
) 
(defun MergePline (all-lines tol / n1 rs) 
  (while all-lines 
    (setq n1 (car all-lines)) 
    (setq all-lines (cdr all-lines)) 
    (setq rs (cons (MergePlineNear n1 tol) rs)) 
  ) 
  rs 
) 
(defun MergeOutPline (all-lines tol / n1 rs r1 r2 pts ps si tmp) 
  (if all-lines 
    (progn 
      (setq pts (mapcar '(lambda (a) (mapcar 'car a)) all-lines)) 
      (setq pts (mapcar 'getPtsCenter pts)) 
      (setq ptn (mapcar '- (apply 'mapcar (cons 'min pts)) '(1 1 1))) 
      (setq si (sortByDistance-i ptn pts)) 
      (setq n1 (nth (car si) all-lines)) 
      (setq all-lines (vl-remove n1 all-lines)) 
      (setq tmp all-lines) 
      (setq r1 (list (MergePlineNear n1 tol))) 
      (setq all-lines tmp) 
      (setq r2 (list (MergePlineNear (lwplineReverse n1) tol))) 
      (if (> (length (car r2)) (length (car r1))) 
        r2 
        r1 
      ) 
    ) 
  ) 
) 
(defun getPtNth2 (s r / p ret) 
  (if r 
    (setq s (reverse s)) 
  ) 
  (setq p (caar s)) 
  (setq ret (caar (setq s (cdr s)))) 
  (while (and (equals p ret 1e-6) 
              (setq s (cdr s)) 
         ) 
    (setq ret (caar s)) 
  ) 
  ret 
) 
;;查找点附近的 
(defun MergeNextPtNear 
                       (lst p0 ps tol clk-p / d        x l res        pts i n1 n0 
                        chklp ptmin ptn) 
  (setq d tol) 
  (mapcar 
    '(lambda (x) 
       (setq l (distance ps (caar x))) 
       (if (and (< l tol) (or (< l d) (equal d l 1e-6))) 
         (if (equal d l 1e-6) 
           (setq res (cons (list x nil) res) 
                 pts (cons (getPtNth2 x nil) pts) 
           ) 
           (setq d   l 
                 res (list (list x nil)) 
                 pts (list (getPtNth2 x nil)) 
           ) 
         ) 
       ) 
       (setq l (distance ps (car (last x)))) 
       (if (and (< l tol) (or (< l d) (equal d l 1e-6))) 
         (if (equal d l 1e-6) 
           (setq res (cons (list x t) res) 
                 pts (cons (getPtNth2 x t) pts) 
           ) 
           (setq d   l 
                 res (list (list x t)) 
                 pts (list (getPtNth2 x t)) 
           ) 
         ) 
       ) 
     ) 
    lst 
  ) 
  (if (> (length pts) 1) 
    (progn 
      (setq ptsr (sortByAngle-i p0 ps pts)) 
      (if clk-p 
        (setq res (nth (last ptsr) res)) 
        (setq res (nth (car ptsr) res)) 
      ) 
    ) 
    (setq res (car res)) 
  ) 
  res                                        ;返回相邻列表，和是否反向 
) 
;;;查找相邻 
(defun MergePlineNear 
       (frst tol / res _f r lastf chkpt ptsr clk-p p rList) 
  (defun _f (ps / res) 
    (if        (setq res (MergeNextPtNear all-lines chkpt ps tol clk-p)) 
      (progn 
        (setq all-lines (vl-remove (car res) all-lines)) 
        (if (cadr res) 
          (lwplineReverse (car res)) 
          (car res) 
        ) 
      ) 
    ) 
  ) 
  (while (and 
           (setq p (caar frst)) 
           (not (member p rList)) 
           (not (< (distance p (car (last frst))) tol)) 
           (setq chkpt (getPtNth2 frst nil)) 
           (setq r (_f p)) 
         )                                ;检查起点 
    (setq rList (cons p rList)) 
 
    (if        (equals (caar r) p 1e-6) 
      (setq r (lwplineReverse r) 
            r (vl-remove (last r) r) 
      ) 
      (setq r (lwplineReverse r)) 
    ) 
    (setq frst (append r frst)) 
  ) 
  (setq clk-p t) 
  (while (and 
           (setq p (car (last frst))) 
           (not (member p rList)) 
           (not (< (distance (caar frst) p) tol)) 
           (setq chkpt (getPtNth2 frst t)) 
           (setq r (_f p)) 
         )                                ;检查终点位置 
    (setq rList (cons p rList)) 
    (if        (equals (caar r) p 1e-6) 
      (setq frst (vl-remove (last frst) frst)) 
    ) 
    (setq frst (append frst r)) 
  ) 
  (if (and (< (distance (caar frst) (car (last frst))) tol) 
           (not (equal (caar frst) (car (last frst)) 1e-6)) 
      ) 
    (setq frst (cons (last frst) frst)) 
  ) 
  frst 
) 
(defun lwplineReverse (pts) 
  (setq pts (Reverse pts)) 
  (mapcar 
    '(lambda (a b) (list (car a) (- (cadr b)))) 
    pts 
    (append (cdr pts) (list (car pts))) 
  ) 
) 
 
;;;三维点集转点集合 
(defun Arr3dToPtlst (tmp / lst) 
  (while tmp 
    (setq lst (appenda lst (list (car tmp) (cadr tmp) (caddr tmp))) 
          tmp (cdddr tmp) 
    ) 
  ) 
  lst 
) 
(defun Arr2dToPtlst (tmp / lst) 
  (while tmp 
    (setq lst (appenda lst (list (car tmp) (cadr tmp) 0)) 
          tmp (cddr tmp) 
    ) 
  ) 
  lst 
) 
 
(defun getCircleCenterByPtsBulge (pt1 pt2 bulge / ptc x1 x2 y1 y2 b) 
  (setq        x1  (car pt1) 
        y1  (cadr pt1) 
        x2  (car pt2) 
        y2  (cadr pt2) 
        b   (* 0.5 (- (/ 1 bulge) bulge)) 
        ptc (list (* 0.5 (+ x1 x2 (- (* b (- y2 y1))))) 
                  (* 0.5 (+ y1 y2 (* b (- x2 x1)))) 
                  0 
            ) 
  ) 
) 
(defun getAngles (pt1 pt2 pt3 / ang a1 a2) 
  (if (or (equal pt2 pt1 1e-6) (equal pt2 pt3 1e-6)) 
    (+ pi pi) 
    (progn 
      (setq ang (- (Angle pt2 pt3) (Angle pt2 pt1))) 
      (if (< ang 0) 
        (setq ang (+ ang pi pi)) 
      ) 
      (if (equal ang 0 1e-6) 
        (+ pi pi) 
        ang 
      ) 
    ) 
  ) 
) 
(defun Equals (a b p) 
  (vl-every '(lambda (x y) (equal x y p)) a b) 
) 
(defun checkPtInArc (ptx ptCircleCenter p1 p2 / r x angx ang1 ang2) 
  (if (not (And (Equals p1 p2 1e-6) (Equals ptx p2))) 
    (progn 
      (setq r (Distance ptx ptCircleCenter)) 
      (setq x (Distance p1 ptCircleCenter)) 
      (If (Equal r x 1e-6) 
        (progn 
          (setq        angx (getAngles p1 ptCircleCenter ptx) 
                ang1 (getAngles p1 ptCircleCenter p2) 
          ) 
          (if (> ang1 angx) 
            t 
            nil 
          ) 
        ) 
      ) 
    ) 
  ) 
) 
(defun checkPtInPtlst (pt pts) 
  (equal (getangles (car pts) pt (cadr pts)) pi 1e-6) 
) 
(defun ArraySort (sortIdx lst) 
  (mapcar '(lambda (n) (nth n lst)) (VL-SORT-I sortIdx '<)) 
) 
(defun BulgeFromArc (ps pe pc bulge / a) 
  (setq a (getangles ps pc pe)) 
  (if (> bulge 0) 
    (tan (* 0.25 a)) 
    (tan (* 0.25 (- a pi pi))) 
  ) 
) 
(defun set3dPtZBy2Pt (pt ptr pte / le lt zr ze z) 
  (setq        zr (caddr ptr) 
        ze (caddr pte) 
  ) 
  (if (and (= zr 0) (= 0 pte)) 
    (list (car pt) (cadr pt) 0) 
    (progn 
      (setq le (Distance ptr pte) 
            lt (Distance ptr pt) 
      ) 
      (If (/= le 0) 
        (setq z (- zr (* lt (/ (- zr ze) le)))) 
        (setq z zr) 
      ) 
      (list (car pt) (cadr pt) z) 
    ) 
  ) 
) 
(defun getPLCenterPt (pt1 pt2 b / pt) 
  (setq pt (mapcar '* '(0.5 0.5 0.5) (mapcar '+ pt1 pt2))) 
  (If (Equals pt pt1 1e-6) 
    pt 
    (Polar pt 
           (- (Angle pt1 pt2) (* 0.5 pi)) 
           (* (Distance pt1 pt2) 0.5 b) 
    ) 
  ) 
) 
(defun appenda (lst a) 
  (append lst (list a)) 
) 
(defun ptTo3D (pt) 
  (if (= (type (car pt)) 'LIST) 
    (mapcar 'ptTo3D pt) 
    (if        (car pt) 
      (list (car pt) 
            (cadr pt) 
            (if        (caddr pt) 
              (caddr pt) 
              0 
            ) 
      ) 
      nil 
    ) 
  ) 
) 
(defun ptTo2D (pt) 
  (if (= (type pt) 'LIST) 
    (if        (= (type (car pt)) 'LIST) 
      (mapcar 'ptTo2D pt) 
      (list (car pt) (cadr pt)) 
    ) 
    (progn pt) 
  ) 
) 
 
(defun Plpts2DToArr (pts / l points) 
  (setq pts (apply 'append (mapcar 'ptto2d pts))) 
  (setq l (cons 0 (1- (length pts)))) 
  (setq points (vlax-make-safearray vlax-vbDouble l)) 
  (vlax-safearray-fill points pts) 
) 
(defun Plpts3DToArr (pts / l points) 
  (setq pts (apply 'append (mapcar 'ptto3d pts))) 
  (setq l (cons 0 (1- (length pts)))) 
  (setq points (vlax-make-safearray vlax-vbDouble l)) 
  (vlax-safearray-fill points pts) 
) 
 
(defun ename->object (s / e lst i _f) 
  (defun _f (e) 
    (if        (= 'ENAME (type e)) 
      (vlax-ename->vla-object e) 
      e 
    ) 
  ) 
  (setq i -1) 
  (if (= (type s) 'PICKSET) 
    (while (setq e (ssname s (setq i (1+ i)))) 
      (setq lst (cons (_f e) lst)) 
    ) 
    (if        (= (type s) 'LIST) 
      (mapcar 'ename->object s) 
      (_f s) 
    ) 
  ) 
) 
(defun cutPolylineByObjs (ssg / i j tmp e f ptsArr objlst) 
  (setq i -1) 
  (setq objlst (ename->object ssg)) 
  (setq i -1) 
  (while (setq e (nth (setq i (1+ i)) objlst)) 
    (setq j i) 
    (while (setq f (nth (setq j (1+ j)) objlst)) 
      (if (setq tmp (vlax-invoke e 'intersectwith f acextendnone)) 
        (setq ptsArr (append ptsArr tmp)) 
      ) 
    ) 
  )   
  (if (> (Length ptsArr) 0) 
    (progn 
      (setq ptsArr (Arr3dToPtlst ptsArr)) 
      (apply 'append 
             (mapcar '(lambda (e) (cutPolyline e ptsArr)) 
                     objlst 
             ) 
      ) 
    ) 
  ) 
) 
(defun cutPolyline (obj               breakPtlst /             ptsArr 
                    jn               EntityName StartWidth i 
                    j               L          Crdnj             Crdn 
                    notDeleteObj          ptxbulge   flg_Bg 
                    ix               ptIx          flg_Wd     ib 
                    Ent               plineLength             ptxEndbulge 
                    widthxS    widthxE          EndWidth   widthx 
                    ptxLst     distAng          ang12             ptxLstDist 
                    isInArc    ptCircleCenter             bulge 
                    cpobj      p1          p2             ptr 
                    pte               ptx          ptc             Coordinates 
                    newCrdnt   Crdnt0          CrdntLst   bulgeLst 
                    newBulges  widthLst          newWidths  dpz 
                    tmp               bCadCutCheckIn             CrdnCar 
                   ) 
  (setq obj (ename->object obj)) 
  (if (> (Length breakPtlst)) 
    (progn 
      (setq ptsArr breakPtlst) 
      (setq EntityName 
             (vla-get-ObjectName obj) 
      ) 
      (if (= EntityName "AcDbPolyline") 
        (setq Coordinates (Arr2dToPtlst (vlax-get obj 'Coordinates))) 
        (setq Coordinates (Arr3dToPtlst (vlax-get obj 'Coordinates))) 
      ) 
      (setq jn 0) 
      (If (= (vla-get-closed obj) :vlax-true) 
        (if (not (Equal        (car Coordinates) 
                        (last Coordinates) 
                        1e-6 
                 ) 
            ) 
          (setq        Coordinates 
                 (append Coordinates (list (car Coordinates))) 
          ) 
        ) 
        (setq ptr (car Coordinates) 
              pte (last Coordinates) 
        ) 
      ) 
      (setq i -1) 
      (while (and (setq p1 (nth (setq i (1+ i)) Coordinates)) 
                  (setq p2 (nth (1+ i) Coordinates)) 
             ) 
        (If (not (Equal p1 p2 1e-6)) 
          (progn 
            (setq bulge (vla-GetBulge obj i)) 
            (vla-GetWidth obj i 'StartWidth 'EndWidth) 
            (If        (/= StartWidth EndWidth) 
              (setq flg_Wd t) 
            ) 
            (If        (/= bulge 0) 
              (progn 
                (setq flg_Bg t) 
                (setq ptCircleCenter 
                       (getCircleCenterByPtsBulge p1 p2 bulge) 
                ) 
                (setq j (1- jn)) 
                ;;检查每个交点 是否在多段线节点线段上 
                (while (setq ptx (nth (setq j (1+ j)) ptsArr)) 
                  (If (> bulge 0) 
                    (setq 
                      isInArc (checkPtInArc ptx ptCircleCenter p1 p2) 
                    ) 
                    (setq 
                      isInArc (checkPtInArc ptx ptCircleCenter p2 p1) 
                    ) 
                  ) 
                                        ;判断交点是否在弧线段上 
                  (If (and isInArc (not (Equals ptx p1 1e-6))) 
                    (progn 
                      (setq ptxLst (append ptxLst (list ptx))) 
                      (if (> bulge 0) 
                        (setq distAng (getAngles p1 ptCircleCenter ptx) 
                              ang12   (getAngles p1 ptCircleCenter p2) 
                        ) 
                        (setq distAng (getAngles ptx ptCircleCenter p1) 
                              ang12   (getAngles p2 ptCircleCenter p1) 
                        ) 
                      ) 
                      (setq tmp (/ distAng ang12)) 
                      (setq ptxLstDist (appenda ptxLstDist tmp)) 
                    ) 
                  ) 
                ) 
              ) 
              (progn 
                (setq j (1- jn))        ;检查每个交点 是否在多段线节点线段上 
                (while (setq ptx (nth (setq j (1+ j)) ptsArr)) 
                  (If (checkPtInPtlst ptx (list p1 p2)) 
                                        ;判断交点是否在线段上 
                    (setq ptxLst     (appenda ptxLst ptx) 
                          dpz             (/ (Distance p1 ptx) (Distance p1 p2)) 
                          ptxLstDist (appenda ptxLstDist dpz) 
                    ) 
                  ) 
                ) 
              ) 
            ) 
            (If        (> (Length ptxLst) 0)        ;是否存在交点 
              (progn 
                (setq ptxLst (ArraySort ptxLstDist ptxLst)) 
                (If 
                  (and (= bulge 0) 
                       (= StartWidth EndWidth) 
                  ) 
                   (progn 
                     (setq tmp (list p1 bulge StartWidth EndWidth)) 
                     (setq newCrdnt (appenda newCrdnt tmp)) 
                     (ForEach ptx ptxLst 
                       (setq tmp (list ptx bulge StartWidth EndWidth)) 
                       (setq newCrdnt (appenda newCrdnt tmp)) 
                       (setq CrdntLst (appenda CrdntLst newCrdnt)) 
                       (setq tmp (list ptx bulge StartWidth EndWidth)) 
                       (setq newCrdnt (list tmp)) 
                     ) 
                   ) 
                   (progn 
                     (setq ptxEndbulge 
                            0 
                           ptxbulge 0 
                           widthxS StartWidth 
                           ptx p1 
                           ix -1 
                     ) 
                     (while (setq ptIx (nth (setq ix (1+ ix)) ptxLst)) 
                       (setq ptxbulge 
                              (BulgeFromArc 
                                ptx 
                                ptIx 
                                ptCircleCenter 
                                bulge 
                              ) 
                       ) 
                       (setq 
                         widthxE 
                          (- StartWidth 
                             (*        (nth ix ptxLstDist) 
                                (- StartWidth EndWidth) 
                             ) 
                          ) 
                       ) 
                       (setq tmp (list ptx ptxbulge widthxS widthxE)) 
                       (setq newCrdnt (appenda newCrdnt tmp)) 
                                        ;存入作为起点 
                       (setq ptx ptIx) 
                       (If (= EntityName "AcDb2DPolyline") 
                         (setq ptx (set3dPtZBy2Pt ptx p1 p2)) 
                       ) 
                       (setq tmp (list ptx 0 0 0)) 
                       (setq newCrdnt (appenda newCrdnt tmp)) 
                                        ;交点存入作为终点 
                       (setq CrdntLst (appenda CrdntLst newCrdnt)) 
                       (Setq newCrdnt nil) 
                       (setq widthxS widthxE) 
                       (setq ptxbulge 
                              (BulgeFromArc 
                                ptx 
                                p2 
                                ptCircleCenter 
                                bulge 
                              ) 
                       ) 
                       (setq tmp (list ptx ptxbulge widthxS EndWidth)) 
                       (setq newCrdnt (appenda newCrdnt tmp)) 
                                        ;px存入作为起点 
                     ) 
                   ) 
                ) 
                (Setq ptxLstDist nil) 
                (Setq ptxLst nil) 
              ) 
              (setq tmp             (list p1 bulge StartWidth EndWidth) 
                    newCrdnt (appenda newCrdnt tmp) 
              )                                ;将点1存如数组 
            ) 
          ) 
        ) 
      ) 
      ;;多段线判断结束 
      (If (> (Length CrdntLst) 0) 
        (progn 
          (if (= (vla-get-closed obj) :vlax-true) 
                                        ;判断闭合保持闭合线收尾相连 
            (setq CrdntLst 
                   (cons (append newCrdnt (car CrdntLst)) 
                         (cdr CrdntLst) 
                   ) 
            ) 
            (setq tmp           (list pte 0 0 0) ;添加末尾点 
                  newCrdnt (appenda newCrdnt tmp) 
                  CrdntLst (appenda CrdntLst newCrdnt) 
            ) 
          ) 
          CrdntLst 
        ) 
      ) 
    ) 
  ) 
)

依然小小鸟 · 发表于 2025-11-13 11:13:40

Sring65 发表于 2025-11-12 17:05

你这个程序加载后的命令是啥我不懂lisp 看不懂

andyzha · 发表于 2025-11-14 13:16:31

这个应用场景挺多的，不错不错

依然小小鸟 · 发表于 13 小时前

搞好了已经

账号		自动登录	找回密码
密码			注册

[提问] 任意曲线转多段线程序！

本帖子中包含更多资源