实现框选一次性倒R角
本帖最后由 aaacjh 于 2012-5-17 21:51 编辑求lisp源码实现：，另外还想实现对已倒过圆角进行框选一次性识别修正的lisp源码。
之前学习lisp时，对矩形编写了以下程序，繁杂又有缺陷，特此求助于高手们，望相助！先行谢过！
(defun c:ffr(/ newrad ss i aa bb va i_list new_rlist n_list newcx newcy)
(setq newrad(getreal "\n请输入新的半径："))
(setq ss(ssget))
(setq i 0)
(repeat (sslength ss)
(setq i_list(entget(ssname ss i)))
(if (= (cdr(assoc 0 i_list)) "ARC")
(progn
(setq bb(assoc 40 i_list))
(setq va(- newrad (cdr bb)))
)
)
)
(setq i 0)
(repeat (sslength ss)
(setq i_list(entget(ssname ss i)))
(cond
((= (cdr(assoc 0 i_list)) "ARC")
(setq new_rlist(cons 40 newrad));创建一个新表
(setq aa(assoc 10 i_list))
(setq i_list(subst new_rlist bb i_list))
(cond
((= 0 (cdr(assoc 50 i_list)))
(setq newcx(- (cadr aa) va))
(setq newcy(- (caddr aa) va))
(setq n_list(subst newcx (cadr aa) aa))
(setq n_list(subst newcy (caddr aa) n_list))
(setq i_list(subst n_list aa i_list))
(entmod i_list)
);;;;;第一象限圆角
((= (/ pi 2) (cdr(assoc 50 i_list)))
(setq newcx(+ (cadr aa) va))
(setq newcy(- (caddr aa) va))
(setq n_list(subst newcx (cadr aa) aa))
(setq n_list(subst newcy (caddr aa) n_list))
(setq i_list(subst n_list aa i_list))
(entmod i_list)
);;;;;第二象限圆角
((= pi (cdr(assoc 50 i_list)))
(setq newcx(+ (cadr aa) va))
(setq newcy(+ (caddr aa) va))
(setq n_list(subst newcx (cadr aa) aa))
(setq n_list(subst newcy (caddr aa) n_list))
(setq i_list(subst n_list aa i_list))
(entmod i_list)
);;;;;第三象限圆角
((= (/ (* 3 pi) 2) (cdr(assoc 50 i_list)))
(setq newcx(- (cadr aa) va))
(setq newcy(+ (caddr aa) va))
(setq n_list(subst newcx (cadr aa) aa))
(setq n_list(subst newcy (caddr aa) n_list))
(setq i_list(subst n_list aa i_list))
(entmod i_list)
);;;;;第四象限圆角
))
((= (cdr(assoc 0 i_list)) "LINE")
(setq s10(assoc 10 i_list))
(setq s11(assoc 11 i_list))
(setq a10(cadr s10))
(setq a11(cadr s11))
(setq t10(caddr s10))
(setq t11(caddr s11))
(cond
((> t10 t11)
(setq td10(subst (- t10 (abs va)) t10 s10))
(setq i_list(subst td10 s10 i_list))
(setq td11(subst (+ t11 (abs va)) t11 s11))
(setq i_list(subst td11 s11 i_list))
(entmod i_list))
((< t10 t11)
(setq td10(subst (+ t10 (abs va)) t10 s10))
(setq i_list(subst td10 s10 i_list))
(setq td11(subst (- t11 (abs va)) t11 s11))
(setq i_list(subst td11 s11 i_list))
(entmod i_list))
((> a10 a11)
(setq ad10(subst (- a10 (abs va)) a10 s10))
(setq i_list(subst ad10 s10 i_list))
(setq ad11(subst (+ a11 (abs va)) a11 s11))
(setq i_list(subst ad11 s11 i_list))
(entmod i_list))
((< a10 a11)
(setq ad10(subst (+ a10 (abs va)) a10 s10))
(setq i_list(subst ad10 s10 i_list))
(setq ad11(subst (- a11 (abs va)) a11 s11))
(setq i_list(subst ad11 s11 i_list))
(entmod i_list))
);修剪直线
)
)
(setq i(1+ i))
)
(print "批量修改成功!")
)
本帖最后由 ketxu 于 2019-11-4 14:57 编辑
I changed it to not depend on Express function
(defun c:fps (/ss pts i ee :ST:SS-Boundingbox :ST:SS->List :ST:SS->ListVla LM:ssget os ov)
(setq
os '(PeditAccept cmdecho)
ov (mapcar 'getvar os)
)
(mapcar 'setvar os '(1 0))
(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)
;Return list ename from ssget
(defun :ST:SS->List(ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons e l))
)
)
;Return list vla Object from s
(defun :ST:SS->ListVla(s)(mapcar 'vlax-ename->vla-object (:ST:SS->List s)))
(defun :ST:SS-Boundingbox ( lst / llp ls1 ls2 urp )
(foreach obj lst
(vla-getboundingbox obj 'llp 'urp)
(setq ls1 (cons (vlax-safearray->list llp) ls1)
ls2 (cons (vlax-safearray->list urp) ls2)
)
)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
)
(or*newrad* (setq *newrad* 1))
(setq *newrad* (getdist (strcat "\nB\U+00E1n k\U+00EDnh fillet <" (rtos *newrad*) "> :")))
(setvar "FilletRad" *newrad*)
;(setq ss (ssget '(( 0 . "LINE,ARC,LWPOLYLINE"))))
(setq ss (LM:ssget "Select Line, Arc, Pline to fillet :" (list '(( 0 . "LINE,ARC,LWPOLYLINE")))))
(setq pts (:ST:SS-Boundingbox (:ST:SS->ListVla ss ))) ; ET func
(command "Pedit" "M" ss "" "J" "" "")
(setq ss (ssget "C" (car pts) (cadr pts) '(( 0 . "LWPOLYLINE")))
i0
)
(while (setq ee (ssname ss i))
(command "Fillet" "P" ee)
(setq i (1+ i))
)
(mapcar 'setvar os ov)
(princ)
) ketxu 发表于 2019-11-4 14:56
I changed it to not depend on Express function
这个可以 就是英文的Bán kính fillet <10.0000> :Select Line, Arc, Pline to fillet : 人家解释，我想，这世界上又要多我这一个疯子了
(defun c:ffr (/ newrad ss pts i ee)
(setq newrad (getreal "\n请输入新的半径："))
(setvar "FilletRad" newrad)
(setq ss (ssget '(( 0 . "LINE,ARC,LWPOLYLINE"))))
(setq pts (acet-geom-ss-extents ss nil)) ; ET func
(SetVar "PeditAccept" 1)
(command "Pedit" "M" ss "" "J" "" "")
(setq ss (ssget "C" (car pts) (cadr pts) '(( 0 . "LWPOLYLINE")))
i0
)
(while (setq ee (ssname ss i))
(command "Fillet" "P" ee)
(setq i (1+ i))
)
)
做个记号:-) Andyhon 发表于 2012-5-18 10:55 static/image/common/back.gif
运行老出现：错误: no function definition: ACET-GEOM-SS-EXTENTS
不知是什么问题？ http://www.google.com/search?as_q=Express+Tools&as_epq=ACET-GEOM-SS-EXTENTS&as_oq=&as_eq=&as_nlo=&as_nhi=&lr=&cr=&as_qdr=all&as_sitesearch=http%3A%2F%2Fbbs.mjtd.com Andyhon 发表于 2012-5-18 10:55 static/image/common/back.gif
长老，您的源码没有效果阿。还有 (setq pts (acet-geom-ss-extents ss nil)) ; ET func
这句是什么意思阿。 http://bbs.mjtd.com/thread-20113-1-1.html
您得学会搜寻喂
acet-geom-ss-extents 得安装 Express Tools
站内有替代方案... 不错，用力效果很好啊 我也正需要顶一个！