求大师一个，曲线断开，分开 生成外轮廓
本帖最后由 世井 于 2025-2-22 17:03 编辑曲线断开，分开 生成外轮廓
(defun c:tt ( / ss obj p1 P9 ss1 n en pt1 pt2 SS2 ssaa s0 iidx SS3 idx ent1)
(setvar "CMDECHO" 0)
(command "_undo" "be")
(setq ss (ssget))
(SETQ obj (baoweihe SS))
(setq p1 (car obj));左下角点
(setq p9 (cadr obj));右上角点
(command "_copyclip" "non" p1 ss "");复制一个隐藏
(SETVAR 'PEDITACCEPT 1) ;转化为多段线
(COMMAND "_.pedit" "m" ss "" "j" 0 "")
(setq ss1 (ssget "w" p9 p1))
(repeat (setq n (sslength ss1))
(setq en(ssname ss1 (setq n (1- n)))
pt1 (vlax-curve-getstartpoint en)
pt2 (vlax-curve-getendpoint en)
)
(command "lengthen" "de" 2 "non" (list en pt1) "non" (list en pt2) "")
)
(setvar "QAFLAGS" 1)
(command "explode" ss1 "")
(setvar "QAFLAGS" 0)
(setq ss2 (ssget "p"))
(COMMAND "_.pedit" "m" ss2 "" "j" 0 "")
(setq ssaa (ssget "w" p9 p1 '((0 . "*POLYLINE,*LWPOLYLINE"))))
(setq s0 (ss->lst ssaa))
(mapcar '(lambda (x) (vla-Offset (Vlax-Ename->Vla-Object x) 15)) s0)
(repeat(setq iidx (sslength ssaa)) (entdel (ssname ssaa (setq iidx (1- iidx)))) )
(setq SS3 (ssget "C" p9 p1 '((0 . "*POLYLINE,*LWPOLYLINE"))))
(LM:outline SS3)
;(set ent1 (entlast))
(repeat(setq idx (sslength SS3))
(entdel (ssname SS3 (setq idx (1- idx)))) ) ;删除原来
;(vla-Offset (Vlax-Ename->Vla-Object ent1) -5)
;(entdel ent1)
(command "_pasteclip" "non" p1)
(command "_undo" "e")
(princ))
(defun ss->lst(ss);选择集转图元名列表
(vl-remove-if(function listp)(mapcar (function cadr) (ssnamex SS))))
(defun baoweihe (sel / idx llp ls1 ls2 obj urp) ;算出包围框
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
(if
(and
(vlax-method-applicable-p obj 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp)))) )
(setq ls1 (cons (vlax-safearray->list llp) ls1)
ls2 (cons (vlax-safearray->list urp) ls2) ) ) )
(if (and ls1 ls2)
(mapcar '(lambda (a b) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2)) ))
(defun LM:outline ( sel / app are box cmd dis enl ent lst obj rtn tmp );创建外轮廓
(if (setq box (LM:ssboundingbox sel))
(progn
(setq app (vlax-get-acad-object)
dis (/ (apply 'distance box) 20.0)
lst (mapcar '(lambda ( a o ) (mapcar o a (list dis dis))) box '(- +))
are (apply '* (apply 'mapcar (cons '- (reverse lst))))
dis (* dis 1.5)
ent
(entmakex
(append
'( (000 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(090 . 4)
(070 . 1)
)
(mapcar '(lambda ( x ) (cons 10 (mapcar '(lambda ( y ) ((eval y) lst)) x)))
'( (caar cadar)
(caadrcadar)
(caadr cadadr)
(caarcadadr)
) )) ))
(apply 'vlax-invoke
(vl-list* app 'zoomwindow
(mapcar '(lambda ( a o ) (mapcar o a (list dis dis 0.0))) box '(- +))) )
(setq cmd (getvar 'cmdecho)
enl (entlast)
rtn (ssadd) )
(while (setq tmp (entnext enl)) (setq enl tmp))
(setvar 'cmdecho 0)
(command"_.-boundary" "_a" "_b" "_n" sel ent "" "_i" "_y" "_o" "_p" "" "_non"
(trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0))) 0 1) "")
(while (< 0 (getvar 'cmdactive)) (command ""))
(entdel ent)
(while (setq enl (entnext enl))
(if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object enl)) 'area)
(equal (vla-get-area obj) are 1e-4) )
(entdel enl)
(ssaddenl rtn)
) )
(vla-zoomprevious app)
(setvar 'cmdecho cmd)
rtn
) ))
(defun LM:ssboundingbox ( s / a b i m n o )
(repeat (setq i (sslength s))
(if (and
(setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
(vlax-method-applicable-p o 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b)))) )
(setq m (cons (vlax-safearray->list a) m)
n (cons (vlax-safearray->list b) n) ) ) )
(if (and m n)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n)) ))
本帖最后由 Sring65 于 2025-6-15 17:58 编辑
(defun c:ObjOutline (/ 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))
(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 5) ;允许误差
(setq ptmrg (MergePline pts tol))
(setq entl(entlast))
(setq entlist (mapcar 'entmakeLWPOLYLINE ptmrg))
(if (setq pts (cutPolylineByObjs (setq olst (vlaOffsetObjs entlist -10))))
(setq ptmrg (MergeOutPline pts 1e-6)) ;合并相邻
)
(while (setq entl(entnext entl))(entdel entl))
(setq entl(entlast))
(foreach e ptmrg
(entmakeLWPOLYLINE e)
)
(vlaOffsetObjs
(vlaOffsetObjs (vlaOffsetObjs (entlast) 5) -10)
5
)
(repeat 3 (setq entl(entnext entl))(entdel entl))
(vla-endundomark acadDoc)
(princ)
)
(defun 转化为多段线 (e / ename)
(setq ename (cdr (assoc 0 (entget e))))
(cond((= ename "CIRCLE") (CircleToBulgePolyline e))
((= ename "ARC") (ArcToBulgePolyline e))
((= ename "ELLIPSE") (ellipseToBulgePolyline e))
((= ename "LINE") (LineToBulgePolyline e))
((wcmatch ename "*POLYLINE") (POLYLINEToBulgePolyline e))
)
)
(defun vlaOffsetObjs (objs len / lst)
(setq objs (ename->object objs))
(setqlst (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 centerradius
ang pointsbulge 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)
(setqpts (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 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 startPtendPt
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))); 结束角度
(setqangleDiff (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 edatacenter
ang a b s e
n thetadeltapoints 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 c:testmirror (/ ent)
(setq ent (car (entsel "\n请选择一个椭圆: ")))
(if (is-ellipse-mirrored ent)
(princ "\n这是一个镜像椭圆。")
(princ "\n这是一个正常椭圆。")
)
(princ)
)
(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)
(setqpt2 (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 pts sorti ptmin clk)
(if all-lines
(progn
(setq pts (mapcar '(lambda (a) (mapcar 'car a)) all-lines))
(setq pts (mapcar 'getPtsCenter pts))
(setq ptmin (apply 'mapcar (cons 'min pts)))
(setq sorti (sortByDistance-i ptmin pts))
(setq n1 (nth (car sorti) all-lines))
(setq all-lines (vl-remove n1 all-lines))
(setq rs (list (MergePlineNear n1 tol)))
)
)
rs
)
;;;查找相邻
(defun MergePlineNear (frst tol / res _f r lastf chkpt ptsr)
(defun _f (ps / res)
(if(setq res (MergeNextPtNear ps tol))
(progn
(setq all-lines (vl-remove (car res) all-lines))
(if (cadr res)
(lwplineReverse (car res))
(car res)
)
)
)
)
;;查找点附近的
(defun MergeNextPtNear (ps tol / d x l res pts i n1 n0 chklp clk-p)
(setq d tol)
(mapcar
'(lambda (x)
(setq l (distance ps (caar x)))
(if (or (and (< l tol) (< l d)) (equal d l 1e-6))
(if (equal d l 1e-6)
(setq res (cons (list x nil) res)
pts (cons (caadr x) pts)
)
(setq d l
res (list (list x nil))
pts (list (caadr x))
)
)
)
(setq l (distance ps (car (last x))))
(if (or (and (< l tol) (< l d)) (equal d l 1e-6))
(if (equal d l 1e-6)
(setq res (cons (list x t) res)
pts (cons (car (nth (- (length x) 2) x)) pts)
)
(setq d l
res (list (list x t))
pts (list (car (nth (- (length x) 2) x)))
)
)
)
)
all-lines
)
(if(> (length pts) 1)
(progn
(setq ptsr (sortByAngle-i chkpt ps pts))
(if clk-p
(setq res (nth (last ptsr) res))
(setq res (nth (car ptsr) res))
)
)
(setq res (car res))
)
res ;返回相邻列表，和是否反向
)
(if (not (CheckPtLstclockwisep (mapcar 'car frst)))
(setq n1 (lwplineReverse frst))
)
(while (and
(not (< (distance (caar frst) (car (last frst))) tol))
(setq chkpt (caadr frst))
(setq r (_f (caar frst)))
) ;检查起点
(setq frst (append (lwplineReverse r) frst))
)
(setq clk-p t)
(while (and
(not (< (distance (caar frst) (car (last frst))) tol))
(setq chkpt (car (nth (- (length frst) 2) frst)))
(setq r (_f (car (last 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)
(setqx1(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 (Equal p1 p2 1e-6) (Equal ptx p2)))
(progn
(setq r (Distance ptx ptCircleCenter))
(setq x (Distance p1 ptCircleCenter))
(If (Equal r x 1e-6)
(progn
(setqangx (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)
(setqzr (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
newBulgeswidthLst newWidthsdpz
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
)
)
(setqCoordinates
(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 (Equal 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 (list ptx 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)
)
)
;;; (setq L (Length CrdntLst))
;;生成多段线
;;; (ForEach CrdnCrdntLst
;;; ;检查每段线段是否在圈内
;;; (If(> (Length Crdn) 1)
;;; (progn
;;; (setq i 1
;;; ptc (getPLCenterPt
;;; (caar Crdn)
;;; (caadr Crdn)
;;; (cadar Crdn)
;;; )
;;; )
;;; (While
;;; (and (nth i Crdn)
;;; (Equals ptc (caar Crdn) 1e-6)
;;; )
;;; (setq ptc (getPLCenterPt
;;; (car (nth i Crdn))
;;; (car (nth (1+ i) Crdn))
;;; (cadr (nth i Crdn))
;;; )
;;; i (1+ i)
;;; )
;;; )
;;; ;;; (If (= (checkPtInObj ptc cutobj) bCadCutCheckIn)
;;; ;判断是否在圈内
;;; ;;生成多段线
;;; (progn
;;; (setq cpobj (vla-copy obj))
;;; (if (= (vla-get-closed cpobj) :vlax-true)
;;; (vla-put-closed cpobj :vlax-false)
;;; )
;;; (setq CrdnCar (mapcar 'car Crdn))
;;; (If (= EntityName "AcDbPolyline")
;;; (vla-put-Coordinates cpobj (Plpts2DToArr CrdnCar))
;;; ;赋值更新多段线段
;;; (vla-put-Coordinates cpobj (Plpts3DToArr CrdnCar))
;;; )
;;; (If (or flg_Bg flg_Wd)
;;; (progn
;;; (setq j -1)
;;; (while (setq Crdnj (nth (setq j (1+ j)) Crdn))
;;; (if flg_Bg
;;; (vla-SetBulge cpobj j (cadr Crdnj))
;;; )
;;; (If flg_Wd
;;; (vla-SetWidth
;;; cpobj
;;; (caddr Crdnj)
;;; (cadddr Crdnj)
;;; )
;;; )
;;; )
;;; )
;;; )
;;; )
;;; ;;; )
;;; )
;;; )
;;; )
CrdntLst
)
)
)
)
)
我想这是明经币难以实现的一个大工程
好像是模具下料孔 本帖最后由 xyp1964 于 2025-2-19 20:09 编辑
本帖最后由 gzcsun 于 2025-2-19 22:24 编辑
自己做一个吧
gzcsun 发表于 2025-2-19 21:56
自己做一个吧
思路非常清晰 gzcsun 发表于 2025-2-19 21:56
自己做一个吧
gzcsun 发表于 2025-2-19 21:56
自己做一个吧
大师，为什么向外偏移15再向内偏移5呢，直接向外偏移10，不可以么 世井 发表于 2025-2-20 19:39
大师，为什么向外偏移15再向内偏移5呢，直接向外偏移10，不可以么
让CAD可以自动计算，外形更圆滑。
你试一下就知道。
页:
[1]
2