多功能修剪的探索

尘缘一生 · 发表于 2023-5-14 17:45:08

本帖最后由尘缘一生于 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---2 3---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 09:58:03

本帖最后由尘缘一生于 2023-5-16 10:04 编辑

再次改写，全部重写，抛弃源代码方式，集成代码100行即可完成
期待更完美的方法实现.....
测试程序
链接：https://pan.baidu.com/s/1YhTKi8dANOLK6GLwu2jBIQ
提取码：2iqf

;;------c:ccut
(defun c:tt (/ a1 b1)
(dgnxj1)
)
;;多功能修剪、连线、清理--------------
;; 三领设计 V3.0 QQ :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:18:09

本帖最后由 chen780404 于 2023-6-3 10:30 编辑

下载附件不能用啊

chen780404 · 发表于 2023-6-3 10:31:07

麻烦解决一下，谢谢！

yefei812678 · 发表于 2024-10-25 08:07:32

谢谢分享谢谢分享

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

多功能修剪的探索

本帖子中包含更多资源

评分

本帖子中包含更多资源