连续旋转复制
初学lisp，菜鸟一枚，因为工作需要写了些简单的lisp函数，随着学习的深入再陆续分享自己写的源码。以下代码能实现连续旋转复制，写得挺简单的，还有些缺陷，望轻喷。若有高手光顾，还望赐教一二，优化一下，谢谢。(defun c:rtc (/ pt1 pt2 pt3 ss a)
(command ".undo" "be")
(setq a (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget))
(setq pt1 (getpoint "选择基点"))
(setq pt2 (getpoint pt1 "\n选择第一角点"))
(while (setq pt3 (getpoint pt1 "\n选择下一角点"))
(command "rotate" ss "" pt1 "c" "r" pt1 pt2 pt3)
)
(setvar "cmdecho" a)
(command ".undo" "e")
)
本帖最后由 ssyfeng 于 2018-4-11 10:26 编辑
我那个改就要用到带捕捉的grread函数，你先试试这个：
(defun c:rtc (/ *error* a pt1 pt2 ptlst1 ptlst2 ss x y z)
(defun *error* (msg)
(setvar "cmdecho" a)
(command ".undo" "e")
(princ "error: ")
(princ msg)
(princ)
)
(defun ent-getbox (ent / lst obj p1 p2 p3 p4)
(setq obj (vlax-ename->vla-object ent))
(vla-GetBoundingBox obj 'p1 'p3)
(setq p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3)
)
(if (= "SPLINE" (cdr (assoc 0 (entget ent))))
(progn
(setq lst
(mapcar
'(lambda (a b)
(vlax-curve-getClosestPointToProjection ent a b t)
)
(list p1
(list (car p1) (cadr p3) (caddr p1))
p3
(list (car p3) (cadr p1) (caddr p1))
)
'((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
)
)
(setq
p1 (apply 'mapcar (cons 'min lst))
p3 (apply 'mapcar (cons 'max lst))
)
)
)
(list p1 p3)
)
(setq a (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget) x nil y nil z t)
(setq pt1 (getpoint "选择基点"))
(setq pt2 (getpoint pt1 "\n选择第一角点"))
(while z
(setq ptlst1 (ent-getbox (entlast))
x (mapcar '(lambda (x) (/ x 2)) (mapcar '+ (car ptlst1) (cadr ptlst1)))
)
(command ".undo" "be")
(command "rotate" ss "" pt1 "c" "r" pt1 pt2 pause)
(command ".undo" "e")
(setq ptlst2 (ent-getbox (entlast))
y (mapcar '(lambda (x) (/ x 2)) (mapcar '+ (car ptlst2) (cadr ptlst2)))
)
(setq z (null (equal x y 0.001)))
)
(command ".undo" "")
(setvar "cmdecho" a)
(princ)
)
ssyfeng 发表于 2018-4-11 10:24
我那个改就要用到带捕捉的grread函数，你先试试这个：
好像不能用，输入命令时没法输入 看看是不是你要的效果：
(defun c:tt (/ *error* a ang ang1 ang2 code code-25 en-lst mat1 pt1 pt2 pt2-0 pt3 ss)
(defun *error* (msg)
(if (or (= msg "*cancelled*")
(= msg "*exit*")
)
(progn
(princ)
(setvar "cmdecho" a)
(mapcar 'entdel en-lst)
(command ".undo" "e")
)
(progn
(princ (strcat "\n错误: " msg))
(setvar "cmdecho" a)
(mapcar 'entdel en-lst)
(command ".undo" "e")
)
)
)
(defun MAT:Rotation ( Cen ang / c s x y)
(setq c (cos ang) s (sin ang))
(setq x (car Cen) y (cadr Cen))
(list
(list c (- s) 0. (- x (- (* c x) (* s y))))
(list s c0. (- y (+ (* s x) (* c y))))
'(0. 0. 1. 0.)
'(0. 0. 0. 1.)
)
)
(defun ywfz (ss / enlst)
(setq enlst (mapcar '(lambda (x) (vlax-invoke-method (vlax-ename->vla-object x) 'copy )) (ss-list ss)))
(mapcar 'vlax-vla-object->ename enlst)
)
(defun ss-list (ss)
(vl-remove-if-not (function (lambda (x) (equal (type x) 'ename))) (mapcar 'cadr (ssnamex ss)))
)
(command ".undo" "be")
(setq a (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget))
(setq pt1 (getpoint "选择基点"))
(setq pt2 (getpoint pt1 "\n选择第一角点")
pt2-0 pt2
code-25 T
)
(while (progn (princ "\n选择下一角点") code-25)
(setq en-lst (ywfz ss))
(while (= 5 (car (setq code (grread T 4))))
(setq pt3 (cadr code)
ang1 (angle pt1 pt2)
ang2 (angle pt1 pt3)
ang (if (< ang1 ang2)
(setq ang (- ang2 ang1))
(setq ang (* -1 (- ang1 ang2)))
)
mat1 (MAT:Rotation pt1 ang)
)
(mapcar '(lambda (x) (vla-transformby (vlax-ename->vla-object x) (vlax-tmatrix mat1))) en-lst)
(setq pt2 pt3)
)
(setq pt2 pt2-0)
(if (= 25 (car code)) (progn (setq code-25 nil) (mapcar 'entdel en-lst)))
)
(setvar "cmdecho" a)
(command ".undo" "e")
(princ)
)
这样就好了 ,
(defun c:rtc (/ pt1 pt2 ss a)
(command ".undo" "be")
(setq a (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget))
(setq pt1 (getpoint "选择基点"))
(while (setq pt2 (getpoint pt1 "\n选择第二点"))
(command "rotate" ss "" pt1 "c" pt2)
)
(setvar "cmdecho" a)
(command ".undo" "e")
) 尒樣僮 发表于 2018-4-7 14:57
这样就好了 ,
这样改的话，就很难预料复制到哪里了 现在的缺陷在于，不能像CAD自带命令那样在复制时实时显示，不能很直观地查看复制过后的状态。我尝试过了，把(command)部分pt3改为pause即可，但是就得想个法子结束循环，目前修改一下可以实现按ESC键结束，但是这样做的话就直接中止了函数，后面的undo不会运行，感觉不是很好呢。 你的意思是要有动态的我也不会
要用到grread这个 尒樣僮 发表于 2018-4-7 15:51
你的意思是要有动态的我也不会
要用到grread这个
看了个grread的实例，感觉不是我想要的，也可能是那个源码的问题 尒樣僮 发表于 2018-4-7 15:51
你的意思是要有动态的我也不会
要用到grread这个
你可以运行一下下面这段修改后的代码（注释了几行），就能明白我要达到的效果哈，按ESC退出。
(defun c:rtc (/ pt1 pt2 pt3 ss a)
;(command ".undo" "be")
;(setq a (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget))
(setq pt1 (getpoint "选择基点"))
(setq pt2 (getpoint pt1 "\n选择第一角点"))
(while t;(setq pt3 (getpoint pt1 "\n选择下一角点"))
(command "rotate" ss "" pt1 "c" "r" pt1 pt2 pause)
)
;(setvar "cmdecho" a)
;(command ".undo" "e")
) ;参照旋转 ZZXXQQ 2013.5.10 http://bbs.mjtd.com/forum.php?mod=viewthread&tid=101306
你改一下应该可以达到你想要的效果
(defun c:`qq()
(setvar "cmdecho" 0);指令执行过程不响应
(setq ss (ssget))
(command "undo" "be")
(setq la (getvar"clayer"))
(command "layer" "m" "3不打印" "C" "44" "" "LW" "0.13" "" "P" "n" "" "" "clayer" la)
(setq pc (getpoint "\n请指定旋转基点:"))
(setq pt (getpoint pc "\n请指定参照点:"))
(command "circle" pc "non" pt)
(command "chprop" (entlast) "" "P" "la" "3不打印" "C" "T" "30,30,30" "")
(setq s2 (entlast))
(setq s1 (entlast) sa (ssadd))
(command "copy" ss "" "0,0" "0,0")
(while (setq s1 (entnext s1))(ssadd s1 sa))
(command "rotate" ss "" pc "R" pc pt pause)
(setq yn (getpoint "\n左键复制,右键不复制"))
(if yn (command "change" ss "" "p" "c" "180" "") (command "erase" sa ""))
(command "erase" s2 "")
(command "undo" "e")
(princ)) 669423907 发表于 2018-4-7 16:37
;参照旋转 ZZXXQQ 2013.5.10 http://bbs.mjtd.com/forum.php?mod=viewthread&tid=101306
你改一下应该可以 ...
好的，我研究一下
页:
[1]
2