又无聊了，发一个源代码 xxdf 智能动态框选倒角 v1.3

狂刀lxx · 发表于 2011-5-10 23:20:55

又无聊了。不打算完善，有需要完善的朋友请自行修改或找别人修改，只要你保留源码的作者信息即可
友情提示：这个程序内包含好几个灰常有用的常用函数......
比如：xxflt = 对fillet命令的加强,可以支持 polyline与arc,ellipse,spline之间的倒角.自动判断是否可倒角.
;| (xss-e e) = 取得标志实体后的新生成实体选集
;|(x@_int e1 e2)求两实体交点表最精简代码-------
;;求两组曲线的交点表.

;| xxdf (智能动态框选倒角) ----by lxx.2007.8
功能: 动态对曲线倒角,支持 line,arc,ellipse,spline,*polyline
特点: 1.智能选线.可框选多个,自动找最靠近的曲线进行倒角.
2.动态.框选时随鼠标移动,实时动态显示倒角结果,可以放弃操作,但绝对不会倒错.
杜绝因错误倒角导致返工.
倒角半径由"filletrad" 系统变量决定.也可先输入fillet命令,选r,调整半径.
返回: nil.倒角过程中命令行无不爽的重复提示.
版本:
v1.3 消除半径过大及无法倒角引起中断退出。
v1.2 支持单选亮显.支持设置倒角半径.支持回退(undo)
v1.1 消除一些bug,支持连续操作(相当于fillet的m选项)
v1.0
|;
;;;=====================================主函数===========================================;;;
(defun c:xxdf (/ !TM !CE !ERR !FR *MYERR A B FR EP1 EP2 GR GRA GRB II OUT OUT2 P1 P2 PP)
(princ "\n xxdf 智能动态框选倒角 v1.3----by lxx.2007.8")
(setvar "TRIMMODE" 1)
(setq !ce (getvar "cmdecho")
!err *error*
!fr (getvar "filletrad")
!tm (getvar "TRIMMODE")
)
(princ (strcat "\n ** " (if (= !tm 0) "不" "" )"剪切;" " 半径="(rtos !fr 2 4)"**"))
;; 自定义出错处理.
(defun *myerr (msg / !CE !ERR !FR !TM *ERROR* P1 PP)
(grvecs (list 0
p1
(list (car p1) (cadr pp))
(list (car p1) (cadr pp))
pp
pp
(list (car pp) (cadr p1))
(list (car pp) (cadr p1))
p1
)
)
(command ".undo" "e")
(setvar "cmdecho" !ce)
(setvar "filletrad" !fr)
(setq *error* !err)
(princ)
)
(setvar "cmdecho" 0)
;;(setq *error* *myerr)
;;循环1.
(while (not out2)
(setq out nil)
(initget "U R ")
(setq P1 (getpoint
"\n选择第一个对象或框选第一点/U-回退/R-半径/<退出>:"
)
)
(cond
((and (= 'STR (type p1)) (= "U" (strcase p1))) ; U 回退.
(command ".undo" 1)
)
((and (= 'STR (type p1)) (= "R" (strcase p1))) ; 半径
(setq fr (getdist "\n 倒角半径/<0>:"))
(setvar "filletrad" (if fr fr 0.))
)
((not p1) ; 退出.
(setq out2 T)
)
((and (listp p1) (setq a (nentselp p1))) ;取第二对象.
(setq ep1 a)
(redraw (car ep1) 3)
(if (and (setq b (entsel "\n 选择第二个对象 <放弃>:"))
(setq ep2 b)
)
(progn (command "_.fillet" ep1 ep2)
(mystopcmd))
)
(redraw (car ep1) 4)
)
((listp p1) ; 取框对角点.
(princ "\n 选择框选第二点/<放弃>:")
(command ".undo" "be");!!! 位置是关键!
(while (not out)
;; 循环2
(setq gr (grread T 15 2)
gra (car gr)
)
(cond; 放弃.(鼠标右键回车键空格)
((member gr '((11 0) (2 13) (2 32)))
(command ".Undo" 1)
(setq out T)
); 关键字
((= 2 gra)
(setq grb (strcase (chr (cadr gr))))
(cond
((= "R" grb) ;输入"R"
)
)
)
((= 3 gra); 鼠标左键确定.
(setq out T)
)
((= 5 gra); 动态取点.
(if (not pp)
(setq pp (cadr gr))
)
(setq p2 (cadr gr))
(if (not (equal p2 pp 1e-1))
(progn
;;清旧框
(grvecs (list 0
p1
(list (car p1) (cadr pp))
(list (car p1) (cadr pp))
pp
pp
(list (car pp) (cadr p1))
(list (car pp) (cadr p1))
p1
)
)
;;画新框
(grvecs (list 1
p1
(list (car p1) (cadr p2))
(list (car p1) (cadr p2))
p2
p2
(list (car p2) (cadr p1))
(list (car p2) (cadr p1))
p1
)
)
(setq pp p2)
(command ".undo" 1)
(dofil p1 p2)
)
)
)
)
)
;; 退出循环2,清选框.
(grvecs (list 0
p1
(list (car p1) (cadr pp))
(list (car p1) (cadr pp))
pp
pp
(list (car pp) (cadr p1))
(list (car pp) (cadr p1))
p1
)
)
)
)
(command ".undo" "e")
)
(setvar "cmdecho" !ce)
(setq *error* !err)
(setq p1 nil)
(princ)
)
;;;=====================================<<<=======================================;;;
;;;==================================核心函数=====================================;;;
;|
dofil = 倒角核心函数.
功能: 自动找到离p1,p2最近的曲线(支持选集多于2个,智能搜索),并倒角.
|;
(defun dofil (p1 p2 / fil ss ssl sss ii1 ii2 a b ep1 ep2 P x )
(setq fil '((0 . "*POLYLINE,SPLINE,LINE,ARC,ELLIPSE")))
(if (and p1
p2
(listp p1)
(listp p2)
(setq p1 (list (car p1) (cadr p1)))
(setq p2 (list (car p2) (cadr p2)))
(not (equal p1 p2))
(setq ss (ssget "c" p1 p2 fil))
)
(progn
(setq ssl (sslength ss))
(cond
((>= ssl 2)
(setq sss (xss2lst ss))
(setq ep1
(mapcar '(lambda (x / p)
(setq p (vlax-curve-getclosestpointto x p1 nil))
(list (distance p1 p) x p)
)
sss
)
)
(setq a(cdr (car (vl-sort ep1 '(lambda (x y) (< (car x) (car y)))))))
(setq ep2
(mapcar '(lambda (x / p)
(setq p (vlax-curve-getclosestpointto x p2 nil))
(list (distance p2 p) x p)
)
sss
)
)
(setq b(cdr (car (vl-sort ep2 '(lambda (x y) (< (car x) (car y)))))))
(xxflt a b); 对fillet命令的加强,可以支持 polyline与arc,ellipse,spline之间的倒角.
)
(T nil)
)
)
)
)
;; 用于中断命令.
(defun mystopcmd ()
(if (/= 0 (getvar "cmdactive"))
(progn
(princ "\r ")
(command)
(princ "\r ")
)
(progn
(princ "\r ")
)
)
)
;|xxflt = 对fillet命令的加强,可以支持 polyline与arc,ellipse,spline之间的倒角.自动判断是否可倒角.
参数: a,b 均为 (元点)表
返回值: nil. 如可以倒角,调用fillet命令生成倒角实体.否,返回nil.
|;
(defun xxflt (a b / AN1 AN2 CEN E1 E1AN1 E1AN2 E1P1 E1P2 E2 E2AN1 E2AN2 E2P1 E2P2 EE EE2 ENT1 ENT2 O1 O2 OO2
P1 P2 R 2PI)
(setq 2PI (* 2 PI))
(if (and a
b
(setq e1 (car a)
ent1 (entget e1)
p1 (cadr a)
)
(setq e2 (car b)
ent2 (entget e2)
p2 (cadr b)
)
(not (equal (car a) (car b)))
(not (equal (cadr a) (cadr b)))
(setq e1p1 (vlax-curve-getstartpoint e1)
e1p2 (vlax-curve-getendpoint e1)
e2p1 (vlax-curve-getstartpoint e2)
e2p2 (vlax-curve-getendpoint e2))
(not(or (equal (rem(angle e1p1 e1p2)2PI) (rem(angle e2p1 e2p2)2PI) 1E-2)
(equal (rem(angle e1p1 e1p2)2PI) (rem(angle e2p2 e2p1)2PI) 1E-2))
) ; for 平行直线
)
(progn
(setq r (getvar "FILLETRAD"))
(if (equal 0.0 r) ; 倒角半径为0 ;;;ok!
(progn
(setvar "TRIMMODE" 1)
(setq ee (entlast))
(command ".fillet" "nea" a "nea" b)
(if (and (not (entnext ee))
(equal ent1 (entget e1))
(equal ent2 (entget e2))
)
;;没有改变,说明fillet不起作用
(progn (mystopcmd) (command ".undo" 1))
(mystopcmd)
)
)
(progn ;半径不为0,先不修剪,如成功,修剪倒角,不成功则无操作并屏蔽出错提示.
(setq ee (entlast))
(setvar "TRIMMODE" 0)
(command ".fillet" "nea" a "nea" b)
(mystopcmd)
(if (and (setq ee2 (entnext ee))
(SETQ ENT2 (entget ee2))
(= "ARC" (cdr (assoc 0 ent2)))
(equal r (cdr (assoc 40 ent2)))
)
(progn ;成功
(setq oo2 (vlax-ename->vla-object ee2)
o1 (vlax-ename->vla-object e1)
o2 (vlax-ename->vla-object e2)
)
(setq an1 (vla-get-startangle oo2)
an2 (vla-get-endangle oo2)
cen (vlax-get oo2 'center)
)
(setq e1an1 (angle cen e1p1)
e1an2 (angle cen e1p2)
e2an1 (angle cen e2p1)
e2an2 (angle cen e2p2)
)
(if
(or (not (and a b an1 an2 e1an1 e1an2 e2an1 e2an2))
(and (angin e1an1 an1 an2)
(angin e1an2 an1 an2)
(not (vlax-invoke o1 'intersectwith oo2 0))
)
(and (angin e2an1 an1 an2)
(angin e2an2 an1 an2)
(not (vlax-invoke o2 'intersectwith oo2 0))
)
) ; 不能剪切倒角. ;(angin a a1 a2)判断a在a1,a2夹角内.
(progn
(command ".undo" 1)
)
(progn ; 能剪切倒角.
(command ".undo" 1)
(setvar "trimmode" 1)
(command ".fillet" "nea" a "nea" b)
(mystopcmd)
)
)
)
(progn ;如不成功.
(mystopcmd)
)
)
(setvar "trimmode" 1)
)
)
)
)
)
;;(vlax-invoke (vlax-ename->vla-object(car(entsel))) 'intersectwith (vlax-ename->vla-object(car(entsel))) 0)
;| (angin a1 a2 a3) = 判断a1在a2,a3夹角内.
测试: (angin 0.3 4.2 0.2)
(angin 0.66 0.5 0.2)
(angin 0.66 0.5 3.4)
|;
(defun angin (a a1 a2)
(if (< a1 a2)
(< a1 a a2)
(or (< a1 a (* 2 PI)) (< 0 a a2))
)
)
;| (xss-e e) = 取得标志实体后的新生成实体选集-----------by lxx.2005.9
参数: e = 实体名
返回: 选择集或nil.
|;
;;
(defun xss-e (e / ss)
(if (= 'ENAME (type e))
(progn
(setq ss (ssadd))
(while (setq e (entnext e))
(if (not(wcmatch (cdr (assoc 0 (entget e))) "VERTEX,SEQEND,ATTRIB"))
(ssadd e ss)
)
)
ss
)
)
)
;|([url=mailto:x@_int]x@_int[/url] e1 e2)求两实体交点表最精简代码-------v1.4 ok----------------------------------陌生人.2004.1
返回: 有交点返回交点表；无交点返回nil. 当(equal e1 e2),为求自身交点.
v1.3完善pline-2004.2 > 因为pline自身交点返回多余顶点. -> 发现pl经过spline化，返回顶点为控制点，有待改进.!
v1.4 测试成功! 对lwpolyline，polyline 成功.
测试: ([url=mailto:x@_int]x@_int[/url] (car(entsel)) (car(entsel))) -> ok! e1= e2支持求自身交点.
(foreach n ([url=mailto:x@_int]x@_int[/url] (setq e (car(entsel))) e) (vl-cmdf ".circle" n "800"))
|;
(defun [url=mailto:x@_int]x@_int[/url] (ent1 ent2 / colst intlst ptlst obj1 obj2 entl1 e0 ent1 entl2 k n)
(setq colst nil
intlst nil
ptlst nil
)
(setq obj1 (vlax-ename->vla-object ent1)
obj2 (vlax-ename->vla-object ent2)
entl1 (entget ent1)
ptlst (xl-div (vlax-invoke obj1 'IntersectWith obj2 0) 3)
) ;vla交点表.
;v1.3　完善pline求自身交点,剔除多余顶点. v1.4改用lsp方法求pl顶点.
(if (and (equal ent1 ent2)
(wcmatch (setq e0 (cdr (assoc 0 entl1))) "LWPOLYLINE,POLYLINE")
)
(progn
(if (= "LWPOLYLINE" e0)
(setq colst (xl-div (vlax-get obj1 'coordinates) 2)) ;lwpl是2! v1.3
(while (and (setq ent1 (entnext ent1)
entl2 (entget ent1)
)
(/= "SEQEND" (cdr (assoc 0 entl2)))
)
;else求 2d & 拟合pl线控制点. v1.4
(setq colst (cons (cdr (assoc 10 entl2)) colst))
)
)
(setq intlst
(apply
'append
(mapcar
'(lambda (x)
(setq k nil)
;!!
(if (foreach n colst
(if (and (equal (car n) (car x) 0.1)
(equal (cadr n) (cadr x) 0.1)
)
(setq K T)
)
k ;不可少!
)
nil
(list x)
)
)
ptlst
)
)
)
) ;end progn
(setq intlst ptlst) ;else
)
intlst
)
;|(xl-div lst nom)表分段. -> 返回分段的表. --------------------梁雄啸.2004.1
; lst ＝表，nom = 分段的子表元素个数(从1开始计).
注意: mapcar 对表操作是从后开始!
|;
(defun xl-div (lst nom / N NLST NOM X)
(setq nlst nil
n 0
) ;是0!!!
(mapcar '(lambda (x)
(if (= n nom)
(setq nlst (append nlst (list (list x)))
n 1
)
(setq nlst (if (null nlst)
(list (list x))
(subst (append (last nlst) (list x)) (last nlst) nlst)
)
n (1+ n)
)
)
)
lst
)
nlst
)
;;;;;;;;;;;;;;;;;;;;;;;;主程序;;;;;;;;;;;;;;;;;;;;;;;;;;
;;求两组曲线的交点表.
;;调用方法: (xssints ss1 ss2)
(defun xssints (ss1 ss2 / n m e1 e2 pts FILTER)
(setq filter '((0 . "line,*polyline,spline,arc,circle,ellipse")))
(if (and ss1
(if (null ss2)
(setq ss2 ss1)
ss2
)
)
(repeat (setq n (sslength ss1))
(setq e1 (ssname ss1 (setq n (1- n))))
(repeat (setq m (sslength ss2))
(setq e2 (ssname ss2 (setq m (1- m)))
pts (append pts ([url=mailto:x@_int]x@_int[/url] e1 e2))
)
)
)
)
pts
)
;;;=====================================<<<=======================================;;;
;; 选集转实体列表.
(defun xss2lst (ss / i e elst)
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(setq elst (cons e elst))
)
(reverse elst)
)
;;;=====================================<<<=======================================;;;
(princ "\n xxdf 智能动态框选倒角 v1.3----by lxx.2007.8")
(princ)

;| xxdf (智能动态框选倒角) ----by lxx.2007.8 
功能: 动态对曲线倒角,支持 line,arc,ellipse,spline,*polyline 
      特点: 1.智能选线.可框选多个,自动找最靠近的曲线进行倒角. 
            2.动态.框选时随鼠标移动,实时动态显示倒角结果,可以放弃操作,但绝对不会倒错. 
              杜绝因错误倒角导致返工. 
      倒角半径由"filletrad" 系统变量决定.也可先输入fillet命令,选r,调整半径. 
返回: nil.倒角过程中命令行无不爽的重复提示. 
版本: 
v1.3 消除半径过大及无法倒角引起中断退出。 
v1.2 支持单选亮显.支持设置倒角半径.支持回退(undo) 
v1.1 消除一些bug,支持连续操作(相当于fillet的m选项) 
v1.0 
|; 
;;;=====================================主函数===========================================;;; 
(defun c:xxdf  (/ !TM !CE !ERR !FR *MYERR A B FR EP1 EP2 GR GRA GRB II OUT OUT2 P1 P2 PP) 
  (princ "\n xxdf 智能动态框选倒角 v1.3----by lxx.2007.8") 
  (setvar "TRIMMODE" 1) 
  (setq !ce  (getvar "cmdecho") 
 !err *error* 
 !fr  (getvar "filletrad") 
 !tm  (getvar "TRIMMODE") 
 ) 
  (princ (strcat "\n ** " (if (= !tm 0) "不" "" )"剪切;" " 半径="(rtos !fr 2 4)"**")) 
  ;; 自定义出错处理. 
  (defun *myerr  (msg / !CE !ERR !FR !TM *ERROR* P1 PP) 
    (grvecs (list 0 
    p1 
    (list (car p1) (cadr pp)) 
    (list (car p1) (cadr pp)) 
    pp 
    pp 
    (list (car pp) (cadr p1)) 
    (list (car pp) (cadr p1)) 
    p1 
    ) 
     ) 
    (command ".undo" "e") 
    (setvar "cmdecho" !ce) 
    (setvar "filletrad" !fr) 
    (setq *error* !err) 
    (princ) 
    ) 
  (setvar "cmdecho" 0) 
  ;;(setq *error* *myerr) 
  ;;循环1. 
  (while (not out2) 
    (setq out nil) 
    (initget "U R  ") 
    (setq P1 (getpoint 
        "\n选择第一个对象或框选第一点/U-回退/R-半径/<退出>:" 
        ) 
   ) 
    (cond 
      ((and (= 'STR (type p1)) (= "U" (strcase p1))) ; U 回退. 
       (command ".undo" 1) 
       ) 
      ((and (= 'STR (type p1)) (= "R" (strcase p1))) ; 半径 
       (setq fr (getdist "\n 倒角半径/<0>:")) 
       (setvar "filletrad" (if fr fr 0.)) 
       ) 
      ((not p1) ; 退出. 
       (setq out2 T) 
       ) 
      ((and (listp p1) (setq a (nentselp p1))) ;取第二对象. 
       (setq ep1 a) 
       (redraw (car ep1) 3) 
       (if (and (setq b (entsel "\n 选择第二个对象 <放弃>:")) 
  (setq ep2 b) 
  ) 
  (progn (command "_.fillet" ep1 ep2) 
    (mystopcmd)) 
  ) 
       (redraw (car ep1) 4) 
       ) 
      ((listp p1) ; 取框对角点. 
       (princ "\n 选择框选第二点/<放弃>:") 
       (command ".undo" "be");!!!  位置是关键! 
       (while (not out) 
  ;; 循环2 
  (setq gr  (grread T 15 2) 
        gra (car gr) 
        ) 
  (cond; 放弃.(鼠标右键 回车键 空格) 
    ((member gr '((11 0) (2 13) (2 32))) 
     (command ".Undo" 1) 
     (setq out T) 
     ); 关键字 
    ((= 2 gra) 
     (setq grb (strcase (chr (cadr gr)))) 
     (cond 
       ((= "R" grb) ;输入"R" 
        ) 
       ) 
     ) 
    ((= 3 gra); 鼠标左键确定. 
     (setq out T) 
     ) 
    ((= 5 gra); 动态取点. 
     (if (not pp) 
       (setq pp (cadr gr)) 
       ) 
     (setq p2 (cadr gr)) 
     (if (not (equal p2 pp 1e-1)) 
       (progn 
  ;;清旧框 
  (grvecs (list 0 
         p1 
         (list (car p1) (cadr pp)) 
         (list (car p1) (cadr pp)) 
         pp 
         pp 
         (list (car pp) (cadr p1)) 
         (list (car pp) (cadr p1)) 
         p1 
         ) 
   ) 
  ;;画新框 
  (grvecs (list 1 
         p1 
         (list (car p1) (cadr p2)) 
         (list (car p1) (cadr p2)) 
         p2 
         p2 
         (list (car p2) (cadr p1)) 
         (list (car p2) (cadr p1)) 
         p1 
         ) 
   ) 
  (setq pp p2) 
  (command ".undo" 1) 
  (dofil p1 p2) 
  ) 
       ) 
     ) 
    ) 
  ) 
       ;; 退出循环2,清选框. 
       (grvecs (list 0 
       p1 
       (list (car p1) (cadr pp)) 
       (list (car p1) (cadr pp)) 
       pp 
       pp 
       (list (car pp) (cadr p1)) 
       (list (car pp) (cadr p1)) 
       p1 
       ) 
        ) 
       ) 
      ) 
    (command ".undo" "e") 
    ) 
  (setvar "cmdecho" !ce) 
  (setq *error* !err) 
  (setq p1 nil) 
  (princ) 
  ) 
;;;=====================================<<<=======================================;;; 
;;;==================================核心函数=====================================;;; 
;| 
dofil = 倒角核心函数. 
功能: 自动找到离p1,p2最近的曲线(支持选集多于2个,智能搜索),并倒角. 
|; 
(defun dofil  (p1 p2 / fil ss ssl sss ii1 ii2 a b ep1 ep2 P x ) 
  (setq fil '((0 . "*POLYLINE,SPLINE,LINE,ARC,ELLIPSE"))) 
  (if (and p1 
    p2 
    (listp p1) 
    (listp p2) 
    (setq p1 (list (car p1) (cadr p1))) 
    (setq p2 (list (car p2) (cadr p2))) 
    (not (equal p1 p2)) 
    (setq ss (ssget "c" p1 p2 fil)) 
    ) 
    (progn 
      (setq ssl (sslength ss)) 
      (cond 
 ((>= ssl 2) 
  (setq sss (xss2lst ss)) 
  (setq ep1 
  (mapcar '(lambda (x / p) 
      (setq p (vlax-curve-getclosestpointto x p1 nil)) 
      (list (distance p1 p) x p) 
      ) 
   sss 
   ) 
        ) 
  (setq a(cdr (car (vl-sort ep1 '(lambda (x y) (< (car x) (car y))))))) 
  (setq ep2 
  (mapcar '(lambda (x / p) 
      (setq p (vlax-curve-getclosestpointto x p2 nil)) 
      (list (distance p2 p) x p) 
      ) 
   sss 
   ) 
        ) 
  (setq b(cdr (car (vl-sort ep2 '(lambda (x y) (< (car x) (car y))))))) 
  (xxflt a b); 对fillet命令的加强,可以支持 polyline与arc,ellipse,spline之间的倒角. 
  ) 
 (T nil) 
 ) 
      ) 
    ) 
  ) 
;; 用于中断命令. 
(defun mystopcmd  () 
    (if (/= 0 (getvar "cmdactive")) 
      (progn 
 (princ "\r                                                                            ") 
 (command) 
 (princ "\r                                                                            ") 
 ) 
      (progn 
 (princ "\r                                                                             ") 
 ) 
      ) 
    ) 
;|xxflt = 对fillet命令的加强,可以支持 polyline与arc,ellipse,spline之间的倒角.自动判断是否可倒角. 
参数: a,b 均为 (元 点)表 
返回值: nil. 如可以倒角,调用fillet命令生成倒角实体.否,返回nil. 
|; 
(defun xxflt  (a b /  AN1 AN2 CEN E1 E1AN1 E1AN2 E1P1 E1P2 E2 E2AN1 E2AN2 E2P1 E2P2 EE EE2 ENT1 ENT2 O1 O2 OO2 
        P1 P2 R 2PI) 
  (setq 2PI (* 2 PI)) 
  (if (and a 
    b 
    (setq e1 (car a) 
     ent1 (entget e1) 
     p1  (cadr a) 
     ) 
    (setq e2 (car b) 
     ent2 (entget e2) 
     p2  (cadr b) 
     ) 
    (not (equal (car a) (car b))) 
    (not (equal (cadr a) (cadr b))) 
    (setq e1p1 (vlax-curve-getstartpoint e1) 
   e1p2 (vlax-curve-getendpoint e1) 
   e2p1 (vlax-curve-getstartpoint e2) 
   e2p2 (vlax-curve-getendpoint e2)) 
    (not(or (equal (rem(angle e1p1 e1p2)2PI) (rem(angle e2p1 e2p2)2PI) 1E-2) 
     (equal (rem(angle e1p1 e1p2)2PI) (rem(angle e2p2 e2p1)2PI) 1E-2)) 
     ) ; for 平行直线 
    ) 
    (progn 
      (setq r (getvar "FILLETRAD")) 
      (if (equal 0.0 r) ; 倒角半径为0 ;;;ok! 
 (progn 
   (setvar "TRIMMODE" 1) 
   (setq ee (entlast)) 
   (command ".fillet" "nea" a "nea" b) 
   (if (and (not (entnext ee)) 
     (equal ent1 (entget e1)) 
     (equal ent2 (entget e2)) 
     ) 
     ;;没有改变,说明fillet不起作用 
     (progn (mystopcmd) (command ".undo" 1)) 
     (mystopcmd) 
     ) 
   ) 
 (progn ;半径不为0,先不修剪,如成功,修剪倒角,不成功则无操作并屏蔽出错提示. 
   (setq ee (entlast)) 
   (setvar "TRIMMODE" 0) 
   (command ".fillet" "nea" a "nea" b) 
   (mystopcmd) 
   (if (and (setq ee2 (entnext ee)) 
     (SETQ ENT2 (entget ee2)) 
     (= "ARC" (cdr (assoc 0 ent2))) 
     (equal r (cdr (assoc 40 ent2))) 
     ) 
     (progn ;成功 
       (setq oo2 (vlax-ename->vla-object ee2) 
      o1 (vlax-ename->vla-object e1) 
      o2 (vlax-ename->vla-object e2) 
      ) 
       (setq an1  (vla-get-startangle oo2) 
      an2  (vla-get-endangle oo2) 
      cen  (vlax-get oo2 'center) 
      ) 
       (setq e1an1 (angle cen e1p1) 
      e1an2 (angle cen e1p2) 
      e2an1 (angle cen e2p1) 
      e2an2 (angle cen e2p2) 
      ) 
       (if 
  (or (not (and a b an1 an2 e1an1 e1an2 e2an1 e2an2)) 
      (and (angin e1an1 an1 an2) 
    (angin e1an2 an1 an2) 
    (not (vlax-invoke o1 'intersectwith oo2 0)) 
    ) 
      (and (angin e2an1 an1 an2) 
    (angin e2an2 an1 an2) 
    (not (vlax-invoke o2 'intersectwith oo2 0)) 
    ) 
      ) ; 不能剪切倒角. ;(angin a a1 a2)判断a在a1,a2夹角内. 
   (progn 
     (command ".undo" 1) 
     ) 
   (progn ; 能剪切倒角. 
     (command ".undo" 1) 
     (setvar "trimmode" 1) 
     (command ".fillet" "nea" a "nea" b) 
     (mystopcmd) 
     ) 
   ) 
       ) 
     (progn ;如不成功. 
       (mystopcmd) 
       ) 
     ) 
   (setvar "trimmode" 1) 
   ) 
 ) 
      ) 
    ) 
  ) 
;;(vlax-invoke (vlax-ename->vla-object(car(entsel))) 'intersectwith  (vlax-ename->vla-object(car(entsel))) 0) 
;| (angin a1 a2 a3) = 判断a1在a2,a3夹角内. 
测试: (angin 0.3 4.2 0.2) 
      (angin 0.66 0.5 0.2) 
      (angin 0.66 0.5 3.4) 
|; 
(defun angin  (a a1 a2) 
  (if (< a1 a2) 
    (< a1 a a2) 
    (or (< a1 a (* 2 PI)) (< 0 a a2)) 
  ) 
) 
 ;| (xss-e e) = 取得标志实体后的新生成实体选集-----------by lxx.2005.9 
参数: e = 实体名 
返回: 选择集或nil. 
|; 
;; 
(defun xss-e  (e / ss) 
  (if (= 'ENAME (type e)) 
    (progn 
      (setq ss (ssadd)) 
      (while (setq e (entnext e)) 
 (if (not(wcmatch (cdr (assoc 0 (entget e))) "VERTEX,SEQEND,ATTRIB")) 
   (ssadd e ss) 
   ) 
 ) 
      ss 
      ) 
    ) 
  ) 
 ;|([url=mailto:x@_int]x@_int[/url] e1 e2)求两实体交点表最精简代码-------v1.4 ok----------------------------------陌生人.2004.1 
返回: 有交点返回交点表；无交点返回nil. 当(equal e1 e2),为求自身交点. 
v1.3完善pline-2004.2 > 因为pline自身交点返回多余顶点. -> 发现pl经过spline化，返回顶点为控制点，有待改进.! 
v1.4 测试成功! 对lwpolyline，polyline 成功. 
测试: ([url=mailto:x@_int]x@_int[/url] (car(entsel)) (car(entsel))) -> ok! e1= e2支持求自身交点. 
      (foreach n ([url=mailto:x@_int]x@_int[/url] (setq e (car(entsel))) e) (vl-cmdf ".circle" n "800")) 
|; 
(defun [url=mailto:x@_int]x@_int[/url]  (ent1 ent2 / colst intlst ptlst obj1 obj2 entl1 e0 ent1 entl2 k n) 
  (setq colst nil 
 intlst nil 
 ptlst nil 
 ) 
  (setq obj1  (vlax-ename->vla-object ent1) 
 obj2  (vlax-ename->vla-object ent2) 
 entl1 (entget ent1) 
 ptlst (xl-div (vlax-invoke obj1 'IntersectWith obj2 0) 3) 
 ) ;vla交点表. 
     ;v1.3　完善pline求自身交点,剔除多余顶点. v1.4改用lsp方法求pl顶点. 
  (if (and (equal ent1 ent2) 
    (wcmatch (setq e0 (cdr (assoc 0 entl1))) "LWPOLYLINE,POLYLINE") 
    ) 
    (progn 
      (if (= "LWPOLYLINE" e0) 
 (setq colst (xl-div (vlax-get obj1 'coordinates) 2)) ;lwpl是2! v1.3 
 (while (and (setq ent1 (entnext ent1) 
     entl2 (entget ent1) 
     ) 
      (/= "SEQEND" (cdr (assoc 0 entl2))) 
      ) 
     ;else求 2d & 拟合pl线控制点. v1.4 
   (setq colst (cons (cdr (assoc 10 entl2)) colst)) 
   ) 
 ) 
      (setq intlst 
      (apply 
        'append 
        (mapcar 
   '(lambda (x) 
      (setq k nil) 
     ;!! 
      (if (foreach n  colst 
     (if (and (equal (car n) (car x) 0.1) 
       (equal (cadr n) (cadr x) 0.1) 
       ) 
       (setq K T) 
       ) 
     k ;不可少! 
     ) 
        nil 
        (list x) 
        ) 
      ) 
   ptlst 
   ) 
        ) 
     ) 
      ) ;end progn 
    (setq intlst ptlst) ;else 
    ) 
  intlst 
  ) 
 ;|(xl-div lst nom)表分段. -> 返回 分段的表.   --------------------梁雄啸.2004.1 
; lst ＝ 表，nom = 分段的子表元素个数(从1开始计). 
 注意: mapcar 对表操作是从后开始! 
|; 
(defun xl-div  (lst nom / N NLST NOM X) 
  (setq nlst nil 
 n    0 
 ) ;是0!!! 
  (mapcar '(lambda (x) 
      (if (= n nom) 
        (setq nlst (append nlst (list (list x))) 
       n   1 
       ) 
        (setq nlst (if (null nlst) 
       (list (list x)) 
       (subst (append (last nlst) (list x)) (last nlst) nlst) 
       ) 
       n   (1+ n) 
       ) 
        ) 
      ) 
   lst 
   ) 
  nlst 
  ) 
;;;;;;;;;;;;;;;;;;;;;;;;主程序;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;求两组曲线的交点表. 
;;调用方法: (xssints ss1 ss2) 
(defun xssints (ss1 ss2 / n m e1 e2 pts FILTER) 
  (setq filter '((0 . "line,*polyline,spline,arc,circle,ellipse"))) 
  (if (and ss1 
    (if (null ss2) 
      (setq ss2 ss1) 
      ss2 
      ) 
    ) 
    (repeat (setq n (sslength ss1)) 
      (setq e1 (ssname ss1 (setq n (1- n)))) 
      (repeat (setq m (sslength ss2)) 
 (setq e2  (ssname ss2 (setq m (1- m))) 
       pts (append pts ([url=mailto:x@_int]x@_int[/url] e1 e2)) 
       ) 
 ) 
      ) 
    ) 
  pts 
  ) 
;;;=====================================<<<=======================================;;; 
;; 选集转实体列表. 
(defun xss2lst (ss / i e elst) 
  (setq i -1) 
  (while (setq e (ssname ss (setq i (1+ i)))) 
    (setq elst (cons e elst)) 
    ) 
  (reverse elst) 
  ) 
;;;=====================================<<<=======================================;;; 
(princ "\n xxdf 智能动态框选倒角 v1.3----by lxx.2007.8") 
(princ)

xvjiex · 发表于 2020-4-17 11:05:14

支持狂刀大侠的无私奉献，对我们明经币少的初学者一大贡献！！！

paulpipi · 发表于 2019-8-18 18:47:12

不错的程序，谢谢分享！要学的太多了

zst1978 · 发表于 2020-8-24 10:45:41

狂刀代码简约而不简单，谢谢

xshrimp · 发表于 2011-5-10 23:31:40

本帖最后由 xshrimp 于 2011-5-10 23:33 编辑

支持.狂刀开源..
狂刀代码简约而不简单!

xjf · 发表于 2011-5-11 12:20:17

猛顶楼主的好贴

石井鱼 · 发表于 2011-5-11 12:23:02

狂刀的作品，个个经典啊

yxl88168 · 发表于 2011-5-11 17:47:14

回复石井鱼的帖子

楼主说的是呀，狂刀就是历害

yshf · 发表于 2011-5-11 23:23:49

谢谢楼主分享！

crazylsp · 发表于 2011-5-12 11:54:41

狂刀太强大了赞一个

zhulei · 发表于 2011-5-12 13:06:30

向狂刀致敬

Andlu-king · 发表于 2011-5-12 15:55:53

不错的程序，谢谢分享，收藏了！

xiaxiang · 发表于 2011-5-12 16:51:26

强烈支持狂刀前辈

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

又无聊了，发一个源代码 xxdf 智能动态框选倒角 v1.3

本帖子中包含更多资源

评分

本帖被以下淘专辑推荐: