多功能修剪的探索
本帖最后由 尘缘一生 于 2023-5-15 15:49 编辑对这一问题再次重写更新：
鉴于多功能修剪的，高效、便捷，探索下很有必要。
本坛原帖，相关贴地址如下：
lee50310 技术原帖
http://bbs.mjtd.com/forum.php?mo ... =%B6%E0%B9%A6%C4%DC
哪么在经历一段时间使用，《三领设计》形成如下过度阶段代码：
注明：代码不能独立运行(嵌套太多），只是能构架，概貌
完善与提高，是必然的，存于此，期待建设性思路......
[*];;多功能修剪----------【开始】-------
[*](defun dgnxj (/ cwp1 cwp2 ss ss0 n nam1 nam2 entlist obj1 intpoints values intlist objname fr cr mid_pta obj_pta mid_ptb obj_ptb lay col
[*] xtrimpnt startpoint endpoint coords flg dd pel pe1 pe2 ang1 ang2 ang3 ang4 ang5 wang1 wang2 ex1 ex2 ex3 ex4 ey1 ey2 ey3 ey4 xk e_lst
[*] valueszero x1 y1 x2 y2 pt1 pt2 pt3 pt4 pin tel pts1 pts2 loop num tt ie dis
[*] )
[*];嵌入可重复的功能------
[*](defun XBreak_StartEnd (obj FromProperty AddZ / Coords CoordsLen StartPoint EndPoint)
[*] (setq Coords (vlax-safearray->list (vlax-variant-value (vlax-get-property obj FromProperty))))
[*] (setq CoordsLen (1- (length Coords)))
[*] (if AddZ
[*] (progn
[*] (setq StartPoint (trans (list (nth 0 Coords) (nth 1 Coords) 0.0) (obj2en obj) 1))
[*] (setq EndPoint (trans (list (nth (- CoordsLen 1) Coords) (nth CoordsLen Coords) 0.0) (obj2en obj) 1))
[*] )
[*] (progn
[*] (setq StartPoint (trans (list (nth 0 Coords) (nth 1 Coords) (nth 2 Coords)) (obj2en obj) 1))
[*] (setq EndPoint (trans (list (nth (- CoordsLen 2) Coords) (nth (- CoordsLen 1) Coords) (nth CoordsLen Coords)) (obj2en obj) 1))
[*] )
[*] )
[*] (list StartPoint EndPoint)
[*])
[*];---------------
[*](defun XBreak_Pnt_in_Bndy (TestPoint BndyPnt1 BndyPnt2 / MinX MaxX MinY MaxY)
[*] (if (< (car BndyPnt1) (car BndyPnt2))
[*] (progn (setq MinX (car BndyPnt1)) (setq MaxX (car BndyPnt2)))
[*] (progn (setq MinX (car BndyPnt2)) (setq MaxX (car BndyPnt1)))
[*] )
[*] (if (< (cadr BndyPnt1) (cadr BndyPnt2))
[*] (progn (setq MinY (cadr BndyPnt1)) (setq MaxY (cadr BndyPnt2)))
[*] (progn (setq MinY (cadr BndyPnt2)) (setq MaxY (cadr BndyPnt1)))
[*] )
[*] (if (and
[*] (>= (car TestPoint) MinX)
[*] (<= (car TestPoint) MaxX)
[*] (>= (cadr TestPoint) MinY)
[*] (<= (cadr TestPoint) MaxY)
[*] )
[*] T
[*] nil
[*] )
[*])
[*];------------------
[*];;求三点之间的角度度数
[*](defun sl:GetInsideAngle (p1 p2 p3)
[*] ((lambda (a) (min a (- 2pi a)))
[*] (rem (+ 2pi (- (angle p2 p1) (angle p2 p3))) 2pi)
[*] )
[*])
[*];------------------
[*];用在两线有夹角时 (当遇到 一条 ┌ 型 (PLINE线)与 一条 (LINE 或 PLINE)线型成ㄈ字型 时在圈选缺口两端处补线) 不做倒圆角避免错误
[*](defun chack_2LP (/ x ss1 en1 kel)
[*] (setq flg 0)
[*] (foreach x dd
[*] (setq ss1 (ssget "C" x x))
[*] (setq en1 (ssname ss1 0))
[*] (if (member (dxf1 en1 0) '("LWPOLYLINE" "POLYLINE"))
[*] (progn
[*] (setq kel (get-pl-pt en1)) ;取出顶点串列
[*] (if (> (length kel) 2) (setq flg 1));flg=1 补线, flg=0 不补线
[*] )
[*] )
[*] )
[*])
[*];-----------------
[*];1.两线相距同时倾斜,若倾斜角度相等 则 设 tt = dd例: \ \ 将圈选到的两端点连成线
[*];2.两线相距同时倾斜,若倾斜角度相等但一高一低 则 设 tt = dd例: \ 将圈选到一高一低两点连成线
[*];dd:为圈的两点
[*];tt:为两线起始点及结束共4个端点 取最靠近的两点 例: 1---23---4则 tt=(点2,点3) 为最靠近的2点
[*](defun chack_ang ()
[*] (if (and
[*] (and
[*] (and (/= wang1 0) (/= wang1 180) (/= wang1 90) (/= wang1 270))
[*] (and (/= wang2 0) (/= wang2 180) (/= wang2 90) (/= wang2 270))
[*] )
[*] (= wang1 wang2)
[*] )
[*] t
[*] nil
[*] )
[*])
[*];-------------------
[*];判断相距两线 同时为 水平 "=" 或垂直 "||" 时 则将圈选到的两端点 dd 设给 tt 否则 tt= 最近的两点
[*](defun chack_ang_hv (/ x pp)
[*] (if (or (eq x1 x2) (eq y1 y2) (= ang1 90) (= ang2 90) (= ang3 90) (= ang4 90) (= ang5 90)) ;相距两线段边点水平或垂直的两点是否相等 例:" = " 或 "||"
[*] ;或两线等长且倾斜与另一边点是否互垂90度 例:"\\"
[*] (setq tt dd) ;若是相等或互垂90度将圈选到的两端点设给 tt
[*] (progn
[*] (setq pp (sl:furthestapart pel)) ;返回给定列表中相距最远的两点
[*] (setq tt pel)
[*] ;两线段在同一线上相距不相交共4点
[*] (foreach x pp (setq tt (remove_ite_list tt x)));去除最远的两点 剩下最近的两点
[*] )
[*] )
[*])
[*];程序开始------------------
[*](setq e_lst (sysvar '("OSMODE" "DIMDEC" "FILLETRAD" "CMDECHO" "ORTHOMODE")))
[*](setvar "OSMODE" 16384)
[*](setvar "CMDECHO" 0)
[*](setvar "ORTHOMODE" 0)
[*](setq cwp1 (getpoint "\n 选择交叉窗口起始角") loop t)
[*](while loop
[*] (setq cwp2 (getcorner cwp1 "\n 选择对角"))
[*] (if (setq ss (ssget "_C" cwp1 cwp2 '((0 . "LINE,ARC,*P*LINE"))))
[*] (progn
[*] (vl-catch-all-apply 'slexpline (list ss))
[*] (vl-catch-all-apply
[*] (function
[*] (lambda ()
[*] (setq ss (ssget "_C" cwp1 cwp2 '((0 . "LINE,ARC,*P*LINE"))))
[*] (setq num (sslength ss))
[*] (cond
[*] ((= num 2)
[*] (setq nam1 (ssname ss 0) nam2 (ssname ss 1))
[*] (setq lay (dxf1 nam1 8))
[*] (setq col (ss-getcolor nam1))
[*] (setq xk (linwind nam1))
[*] (setq ValuesZero (obj-initpoint nam1 nam2 0)) ;两物体不扩展两个对象求焦点
[*] (setq Values (obj-initpoint nam1 nam2 3)) ;两物体扩展两个对象求焦点
[*] (setq pt1 (vlax-curve-getStartPoint nam1))
[*] (setq pt2 (vlax-curve-getEndPoint nam1))
[*] (setq pt3 (vlax-curve-getStartPoint nam2))
[*] (setq pt4 (vlax-curve-getEndPoint nam2))
[*] (setq pel (list pt1 pt2 pt3 pt4))
[*] (if (setq dd (find_rect_point cwp1 cwp2 pel)) ;找出在矩形两点对角区域内的点
[*] (progn
[*] (setq x1 (caar dd) y1 (cadar dd) x2 (caadr dd) y2 (cadadr dd))
[*] (setq ex1 (car pt1) ey1 (cadr pt1) ex2 (car pt2) ey2 (cadr pt2) ex3 (car pt3) ey3 (cadr pt3) ex4 (car pt4) ey4 (cadr pt4))
[*] (setq wang1 (read (rtos (sl-r2d (angle pt1 pt2)) 2 0))) ;线段1在空间中的角度值
[*] (setq wang2 (read (rtos (sl-r2d (angle pt3 pt4)) 2 0))) ;线段2在空间中的角度值
[*] (if (or (= wang1 180) (= wang1 360)) (setq wang1 0))
[*] (if (or (= wang2 180) (= wang2 360)) (setq wang2 0))
[*] (if (= wang1 270) (setq wang1 90))
[*] (if (= wang2 270) (setq wang2 90))
[*] (setq ang1 (read (rtos (sl-r2d (sl:GetInsideAngle pt1 pt2 (car dd))) 2 0)));线段1两端点与对边另一点a所夹角度 ps: dd为滑鼠圈选的两点(a,b)
[*] (setq ang2 (read (rtos (sl-r2d (sl:GetInsideAngle pt3 pt4 (cadr dd))) 2 0)));线段2两端点与对边另一点a所夹角度
[*] (setq ang3 (read (rtos (sl-r2d (sl:GetInsideAngle pt1 pt2 (cadr dd))) 2 0)));线段1两端点与对边另一点b所夹角度
[*] (setq ang4 (read (rtos (sl-r2d (sl:GetInsideAngle pt3 pt4 (cadr dd))) 2 0)));线段2两端点与对边另一点b所夹角度
[*] (setq ang5 (read (rtos (sl-r2d (sl:GetInsideAngle pt4 pt3 (cadr dd))) 2 0)))
[*] (if (> (vlax-safearray-get-u-bound ValuesZero 1) 0) ;两对象不延伸是否有焦点值
[*] (progn
[*] (setq pin (vlax-safearray->list Values));取焦点
[*] (setq tel pel)
[*] (foreach ie dd
[*] (setq tel (vl-remove-if '(lambda (x) (equal x ie)) tel))
[*] )
[*] (entdel nam1)
[*] (entdel nam2)
[*] (setq pts1 (list (car tel) pin))
[*] (setq pts2 (list (cadr tel) pin))
[*] (slch:lwpolyline (cons (car pts1) pts1) nil xk lay col nil)
[*] (slch:lwpolyline (cons (car pts2) pts2) nil xk lay col nil)
[*] )
[*] (progn
[*] (if (> (vlax-safearray-get-u-bound Values 1) 0);两对象延伸有焦点
[*] (progn ;两线夹一个角度有交点
[*] ;当相距两线 呈水平或垂直时 两线不做倒角
[*] (if (or
[*] (and
[*] (or (/= wang1 0) (/= wang1 180)) ;若(线1与线2皆成水平)
[*] (or (/= wang2 0) (/= wang2 180))
[*] )
[*] (and
[*] (or (/= wang1 90) (/= wang1 270)) ;若(线1与2线皆成垂直)
[*] (or (/= wang2 90) (/= wang2 270))
[*] )
[*] )
[*] (progn
[*] (chack_2LP);判断两线使否为一条 ┌ 型(PLINE) 与一条底线 形成ㄈ字型若是 flg=1
[*] (if (= flg 1)
[*] (slch:lwpolyline (cons (car dd) dd) nil xk lay col nil);补一条线
[*] (progn
[*] (setq mid_ptA (sl:mid pt1 pt2))
[*] (setq obj_ptA (list nam1 mid_ptA));(将物件名称A与中点 结合为串列)----倒圆角用
[*] (setq mid_ptB (sl:mid pt3 pt4))
[*] (setq obj_ptB (list nam1 mid_ptB));(将物件名称B与中点 结合为串列)----倒圆角用
[*] (setq fr (getvar "FILLETRAD") cr (getvar "CHAMFERA"))
[*] (if (> fr 0) (setq a "1") (setq a "0"))
[*] (if (> cr 0) (progn (setq b "1" ca cr cb cr)) (setq b "0"))
[*] (setq flg (strcat a b))
[*] (cond
[*] ((= flg "00") (command "fillet" mid_ptA mid_ptB)) ;两线段做倒圆角 R=0
[*] ((= flg "10") (command "fillet" mid_ptA mid_ptB)) ;两线段做倒圆角 依 R值
[*] ((= flg "01") (command "chamfer" "t" "t" "d" ca cb "chamfer" mid_ptA mid_ptB "")) ;两线段做倒角 依 R值
[*] ((= flg "11") (command "fillet" mid_ptA mid_ptB)) ;两线段做倒角 依 R值
[*] )
[*] )
[*] )
[*] )
[*] )
[*] )
[*] (progn;延伸无焦点:两线平行、垂直或在同一线上但不相交
[*] (if (or (= ex1 ex2 ex3 ex4) (= ey1 ey2 ey3 ey4)) ;在同一线上相距的两线段特性 水平:y轴值相等 ,垂直:x轴值相等
[*] (progn
[*] (setq tt dd)
[*] (slch:lwpolyline (cons (car tt) tt) nil xk lay col nil);在两线间补一段多段线
[*] (ssduppe (sl:pickset-fromlist (list nam1 nam2 (entlast))))
[*] )
[*] (progn
[*] (chack_ang_hv) ;判断相距两线 同时为 水平 "=" 或垂直 "||" 时
[*] ;则将圈选到的两端点 dd 设给 tt 否则 tt= 最近的两点
[*] (if (= (chack_ang) t)
[*] (progn
[*] (setq tt dd)
[*] (slch:lwpolyline (cons (car tt) tt) nil xk lay col nil);在两线间补一段多段线
[*] )
[*] (progn
[*] (setq tt dd)
[*] (slch:lwpolyline (cons (car tt) tt) nil xk lay col nil);在两线间补一段多段线
[*] )
[*] )
[*] )
[*] )
[*] )
[*] )
[*] )
[*] )
[*] )
[*] (slccut cwp1 cwp2) ;框内无点,进行窗剪
[*] )
[*] );2物体
[*] ((= num 4)
[*] (if (pxxxss ss)
[*] (progn
[*] (setq Entlist (ss-enlst ss))
[*] (setq x nil)
[*] ;获取实体的交集
[*] (foreach x Entlist
[*] (setq n 0)
[*] (repeat (length Entlist) ;串列内所包含元体的数量
[*] (if (/= x (setq nam2 (nth n Entlist))) ;假如图元不取到自身则往下执行
[*] (progn
[*] (setq Values (obj-initpoint x nam2 0)) ;两物体不扩展任一对象求焦点
[*] (if (> (vlax-safearray-get-u-bound Values 1) 0) ;两对象延伸是否有焦点?
[*] (progn
[*] (setq XTrimPnt (vlax-safearray->list Values));取焦点
[*] (if (not (assoc x IntList))
[*] (setq IntList (cons (cons x (list XTrimPnt)) IntList))
[*] (setq IntList (subst (cons x (cons XTrimPnt (cdr (assoc x IntList)))) (assoc x IntList) IntList));替换串列表中的元素
[*] )
[*] )
[*] )
[*] )
[*] );如果不是同一个实体
[*] (setq n (1+ n))
[*] )
[*] )
[*] (foreach x IntList
[*] (setq obj1 (en2obj (car x)))
[*] (setq objName (vla-Get-objectName obj1))
[*] (setq XTrimPnt (trans (cadr x) 0 1))
[*] (cond
[*] ((= 2 (length (cdr x)))
[*] (setq EndPoint (trans (caddr x) 0 1))
[*] (command "._Break" (ssadd (car x)) XTrimPnt EndPoint)
[*] (setq EndPoint nil)
[*] );cond points length of 2
[*] ;line overrun scenario
[*] ((= 1 (length (cdr x)));获取段的最近端点
[*] (cond
[*] ((or (= objName "AcDbLine") (= objName "AcDbArc"))
[*] (setq StartPoint (trans (vlax-safearray->list (vlax-variant-value (vla-get-StartPoint obj1))) 0 1))
[*] (setq EndPoint (trans (vlax-safearray->list (vlax-variant-value (vla-get-EndPoint obj1))) 0 1))
[*] )
[*] ((= objName "AcDbPolyline")
[*] (setq Coords (XBreak_StartEnd obj1 "Coordinates" T))
[*] (setq StartPoint (car Coords))
[*] (setq EndPoint (cadr Coords))
[*] )
[*] ((= objName "AcDb3dPolyline")
[*] (setq Coords (XBreak_StartEnd obj1 "Coordinates" nil))
[*] (setq StartPoint (car Coords))
[*] (setq EndPoint (cadr Coords))
[*] )
[*] ((= objName "AcDbSpline")
[*] (setq Coords (XBreak_StartEnd obj1 "ControlPoints" nil))
[*] (setq StartPoint (car Coords))
[*] (setq EndPoint (cadr Coords))
[*] )
[*] (T (setq XTrimPnt nil StartPoint nil EndPoint nil))
[*] )
[*] (if (and XTrimPnt StartPoint EndPoint (not (equal XTrimPnt StartPoint 0.01)) (not (equal XTrimPnt EndPoint 0.01)))
[*] (if (< (distance XTrimPnt StartPoint) (distance XTrimPnt EndPoint))
[*] (if (XBreak_Pnt_in_Bndy StartPoint cwp1 cwp2)
[*] (command "._Break" (ssadd (car x)) XTrimPnt StartPoint)
[*] )
[*] (if (XBreak_Pnt_in_Bndy EndPoint cwp1 cwp2)
[*] (command "._Break" (ssadd (car x)) XTrimPnt EndPoint)
[*] )
[*] );要修剪那一端
[*] )
[*] )
[*] )
[*] )
[*] )
[*] (slccut cwp1 cwp2) ;窗剪
[*] )
[*] )
[*] ((and (> num 2) (/= num 4))
[*] (if (pxxxss ss)
[*] (progn
[*] (break_with ss t) ;交点断开
[*] (setq ang1 (angle cwp1 cwp2) dis (distance cwp1 cwp2))
[*] (if (= (sslength (setq ss0 (ssget "W" (polar cwp1 ang1 (* dis 1.01)) (polar cwp2 (+ ang1 pi) (* dis 1.01)) '((0 . "LINE,ARC,*P*LINE"))))) 1)
[*] (entdel (ssname ss0 0))
[*] (del-lin-min ss0) ;删除集中最短线相同的线集
[*] )
[*] )
[*] (slccut cwp1 cwp2) ;窗剪
[*] )
[*] )
[*] ((= num 1)
[*] (slccut cwp1 cwp2) ;进行窗剪
[*] )
[*] )
[*] )
[*] )
[*] )
[*] (setq cwp1 (getpoint "\n 选择交叉窗口起始角"))
[*] )
[*] (setq loop nil) ;空选退出
[*] )
[*] (setq Entlist nil IntList nil)
[*])
[*](mapcar 'eval e_lst) ;;多功能修剪------【结束】------
[*])
[*]
本帖最后由 尘缘一生 于 2023-5-16 10:04 编辑
再次改写，全部重写，抛弃源代码方式，集成代码100行即可完成
期待更完美的方法实现.....
测试程序
链接：https://pan.baidu.com/s/1YhTKi8dANOLK6GLwu2jBIQ
提取码：2iqf
[*];;------c:ccut
[*](defun c:tt (/ a1 b1)
[*](dgnxj1)
[*])
[*];;多功能修剪、连线、清理--------------
[*];; 三领设计 V3.0QQ :15290049
[*](defun dgnxj1 (/ cwp1 cwp2 ss ss0 nam1 nam2 lay col p0 pt1 pt2 pt3 pt4 pin pts1 pts2 num dis dd ang1 xk)
[*](setq cwp1 (getpoint "\n 选择交叉窗口起始角"))
[*](while cwp1
[*] (setq cwp2 (getcorner cwp1 "\n 选择对角"))
[*] (if (setq ss (ssget "C" cwp1 cwp2 '((0 . "LINE,ARC,*P*LINE")))) ;if-1
[*] (progn
[*] (slexpline ss) ;炸开线型实体成单段，宽度不变
[*] (setq ss nil)
[*] (if (setq ss (ssget "C" cwp1 cwp2 '((0 . "LINE,ARC,*P*LINE"))) num (sslength ss)) ;if-2
[*] (cond
[*] ((= num 1)
[*] (slccut cwp1 cwp2) ;进行窗剪
[*] )
[*] ((= num 2)
[*] (setq nam1 (ssname ss 0) nam2 (ssname ss 1))
[*] (setq lay (dxf1 nam1 8))
[*] (setq col (ss-getcolor nam1))
[*] (setq xk (linwind nam1))
[*] (setq pt1 (vlax-curve-getStartPoint nam1))
[*] (setq pt2 (vlax-curve-getEndPoint nam1))
[*] (setq pt3 (vlax-curve-getStartPoint nam2))
[*] (setq pt4 (vlax-curve-getEndPoint nam2))
[*] (setq p0 (sl:mid cwp1 cwp2))
[*] (if (setq dd (find_rect_point cwp1 cwp2 (list pt1 pt2 pt3 pt4))) ;找出在矩形两点对角区域内的点
[*] (progn
[*] (if (setq pin (car (sl-Curveinters nam1 nam2 0)));两对象有实际交点
[*] (progn
[*] (if (< (distance pt1 p0) (distance pt2 p0))
[*] (slch:lwpolyline (list pt2 pin) nil xk lay col nil)
[*] (slch:lwpolyline (list pt1 pin) nil xk lay col nil)
[*] )
[*] (if (< (distance pt3 p0) (distance pt4 p0))
[*] (slch:lwpolyline (list pt4 pin) nil xk lay col nil)
[*] (slch:lwpolyline (list pt3 pin) nil xk lay col nil)
[*] )
[*] (entdel nam1)
[*] (entdel nam2)
[*] )
[*] )
[*] (if (setq pin (car (sl-Curveinters nam1 nam2 3))) ;两对象延伸有交点
[*] (progn
[*] (setq pts1 (sl:furthestapart (list pt1 pt2 pin)))
[*] (slch:lwpolyline (list (car pts1) (last pts1)) nil xk lay col nil)
[*] (setq pts2 (sl:furthestapart (list pt3 pt4 pin))) ;点表距离最远2个点
[*] (slch:lwpolyline (list (car pts2) (last pts2)) nil xk lay col nil)
[*] (entdel nam1)
[*] (entdel nam2)
[*] (pljoinfuzz (ssget "C" cwp1 cwp2 '((0 . "LINE,ARC,*P*LINE")))) ;模糊距离连线
[*] )
[*] (progn ;延伸无交点
[*] (if (= (sl:pts-onLine (list pt1 pt2 pt3 pt4)) nil) ;不共线
[*] (if (= (length dd) 2)
[*] (slch:lwpolyline (list (car dd) (cadr dd)) nil xk lay col nil)
[*] (slccut cwp1 cwp2) ;一点时,进行窗剪-->>此情况开发还好多!!
[*] )
[*] (progn ;共线即连线
[*] (entdel nam1)
[*] (entdel nam2)
[*] (setq pts1 (sl:furthestapart (list pt1 pt2 pt3 pt4)))
[*] (slch:lwpolyline (list (car pts1) (last pts1)) nil xk lay col nil)
[*] )
[*] )
[*] )
[*] )
[*] )
[*] (slccut cwp1 cwp2) ;框内无点,进行窗剪
[*] )
[*] );2物体
[*] ((> num 2)
[*] (if (pxxxss ss)
[*] (progn
[*] (vl-catch-all-apply (function (lambda () (break_with ss t)))) ;交点断开
[*] (setq ang1 (angle cwp1 cwp2) dis (distance cwp1 cwp2))
[*] (if (setq ss0 (ssget "W" (polar cwp1 ang1 (* dis 1.01)) (polar cwp2 (+ ang1 pi) (* dis 1.01)) '((0 . "LINE,ARC,*P*LINE"))))
[*] (if (= (sslength ss0) 1)
[*] (entdel (ssname ss0 0))
[*] (del-lin-min ss0) ;删除集中最短线相同的线集
[*] )
[*] )
[*] )
[*] (slccut cwp1 cwp2) ;窗剪
[*] )
[*] )
[*] ) ;cond
[*] ) ;if-2
[*] )
[*] ) ;if-1
[*] (setq ss nil)
[*] (setq cwp1 (getpoint "\n 选择交叉窗口起始角"))
[*]) ;while
[*](princ)
[*]) ;;多功能修剪、连线、清理------
本帖最后由 chen780404 于 2023-6-3 10:30 编辑
下载附件不能用啊 麻烦解决一下，谢谢！ 谢谢分享谢谢分享
页:
[1]