- 积分
- 25355
- 明经币
- 个
- 注册时间
- 2013-1-25
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
本帖最后由 尘缘一生 于 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) ;;多功能修剪------【结束】------
- )
|
本帖子中包含更多资源
您需要 登录 才可以下载或查看，没有账号？注册
x
评分
-
查看全部评分
|
发表于 2023-5-14 17:45
置顶卡
变色卡
显身卡
楼主