【Gu_xl】动态复制、移动（可缩放、旋转、镜像、对齐等）
本帖最后由 牢固 于 2013-9-24 15:36 编辑功能：选择对象进行复制或移动。复制或移动过程中可以对源对象进行缩放、旋转、镜像、对齐等动作。
源码中大量使用了矩阵运算（使用了高飞鸟的矩阵运算函数库）和动态GRREAD（自定义的带捕捉的GRREAD函数）。
程序为开源代码，程序中可能有Bug,也可能不符合您平时画图习惯，请大家不要发帖求我改进或改编成符合您的绘图方式的程序，该源码仅作为大家学习交流的代码，大家尽可以拿去研习，可以提出改进意见，然后自己改编成合适自己绘图的方式的程序，或进一步改进优化，如大家能将自己改进的代码发上来共享，本人将不胜感激，一律给予适当加分！
主程序代码：
;;;*************************************************
(princ "\n**动态复制、移动 By Gu_xl 命令: DynDrag**")
;;动态复制、移动(c:DynDrag)
(defun c:DynDrag (/ SS ORIGN LOOP COPYFLAG BASEPT
AXORIGNAXBASEPT SOURCEOBJS TARGETOBJS
TMP GR PT TMAT NEWORIGN
ROT P1 P2 SCALE P3
P4 TARGETDIS REFDIS LASTOBJS LASTBASEPT
KD MOVEFLAG TMPBASEPT
)
(princ "\n选择物体:")
(if (and
(setq ss (ssget))
(progn
(initget 6)
(setq orign (getpoint "\n选择基点:"))
)
(setq Loop t)
)
(progn
(initget "C M")
(setq copyflag (getkword "\n[复制<C>/移动<M>]<C>:"))
(setq copyflag (or (not copyflag) (= "C" copyflag)))
(setq basept (trans orign 1 0))
(setq SourceObjs
(gxl-SEL-MAPCAR
ss
'(lambda (x) (vlax-ename->vla-object x))
)
)
(if CopyFlag
(setq targetObjs (mapcar 'vla-copy SourceObjs))
(progn
(setq targetObjs SourceObjs)
(setq SourceObjs (mapcar 'vla-copy SourceObjs))
)
)
(setq ss (ssadd)
MoveFlag t)
(foreach obj targetObjs (ssadd (vlax-vla-object->ename obj) ss))
;(setq lastobjs SourceObjs lastbasept basept)
(prompt "\r**点取位置或 {改基点/改转角/转90度/镜像/左右翻/上下翻/缩放/对齐/}<退出>:")
(while loop
(setq gr (gxl-GE-GRREAD '(t 15) orign ss))
(princ "\r**点取位置或 {改基点/改转角/转90度/镜像/左右翻/上下翻/缩放/对齐/}<退出>:")
(cond
((and MoveFlag (= 5 (car gr))) ;_ 复制移动
(grdraw orign (cadr gr) 7 1)
(setq pt (trans (cadr gr) 1 0))
(if (> (distance pt basept) (* 0.005 (getvar "viewsize")))
(progn
(setq tmat (vlax-tmatrix (gxl-Mat-TranslateBy2P basept pt)))
(mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
(setq basept pt)
(mapcar '(lambda (x) (vla-Highlight x :vlax-true)) targetObjs)
)
)
)
((and MoveFlag (= 3 (car gr))) ;_ 确定
(grdraw orign (cadr gr) 7 1)
(setq pt (trans (cadr gr) 1 0))
(setq tmat (vlax-tmatrix (gxl-Mat-TranslateBy2P basept pt)))
(mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
(setq lastObjs targetObjs lastbasept basept)
(if copyflag
(progn
(setq targetObjs (mapcar 'vla-copy targetObjs))
(setq ss (ssadd))
(foreach obj targetObjs
(ssadd (vlax-vla-object->ename obj) ss)
)
)
(progn
(setq MoveFlag nil)
(mapcar 'vla-delete SourceObjs)
)
)
)
((or (= 25 (car gr)) ;_ 退出
(and (= 2 (car gr)) (or (= (cadr gr) 13) (= (cadr gr) 32)))
)
(redraw)
(if copyFlag
(progn
(mapcar 'vla-delete targetObjs)
)
)
(setq loop nil)
)
((and (= 2 (car gr))
(or (= (cadr gr) (ascii "t")) (= (cadr gr) (ascii "T")))
) ;_ 改基点
(redraw)
(if (and
(not copyflag)
lastobjs
)
(progn
(initget 6)
(while (not (setq Neworign (getpoint "\n选择基点:"))))
(setq Neworign (trans Neworign 1 0))
(setq tmat (vlax-tmatrix (gxl-Mat-TranslateBy2Pbasept Neworign)))
(mapcar '(lambda (x)(vla-TransformBy x tmat)) lastobjs)
(setq basept Neworign)
)
(if (and copyflag lastobjs)
(progn
(mapcar '(lambda (x) (vla-put-Visible x :vlax-false)) targetObjs)
(initget 6)
(while (not (setq Neworign (getpoint "\n选择基点:"))))
(setq Neworign (trans Neworign 1 0))
(setq tmat (vlax-tmatrix (gxl-Mat-TranslateBy2P lastbasept Neworign)))
(mapcar '(lambda (x)(vla-TransformBy x tmat)) lastobjs)
(mapcar '(lambda (x) (vla-put-Visible x :vlax-true)) targetObjs)
)
(progn
(while (not (setq basept (getpoint "\n选择基点:"))))
(setq basept (trans basept 1 0))
)
)
)
)
((and (= 2 (car gr))
(or (= (cadr gr) (ascii "r")) (= (cadr gr) (ascii "R")))
) ;_ 改转角
(setq tmp targetObjs tmpbasept basept)
(if copyflag
(progn
(mapcar '(lambda (x) (vla-put-Visible x :vlax-false)) tmp)
(setq targetObjs lastObjs basept lastbasept)
(setq ss (ssadd))
(foreach obj targetObjs
(ssadd (vlax-vla-object->ename obj) ss)
)
)
)
(command "_rotate" ss "" (trans basept 0 1))
(while (= 1 (logand (getvar 'cmdactive) 1))
(command pause)
)
(if copyflag
(progn
(mapcar '(lambda (x) (vla-put-Visible x :vlax-true)) tmp)
(setq targetObjs tmp basept tmpbasept)
(setq ss (ssadd))
(foreach obj targetObjs
(ssadd (vlax-vla-object->ename obj) ss)
)
)
)
)
((andMoveFlag
(= 2 (car gr))
(or (= (cadr gr) (ascii "a")) (= (cadr gr) (ascii "A")))
) ;_ 转90度
(setq tmat (vlax-tmatrix (gxl-Mat-Rotation basept pi2)))
(mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
)
((and MoveFlag
(= 2 (car gr))
(or (= (cadr gr) (ascii "m")) (= (cadr gr) (ascii "M")))
) ;_ 镜像
(initget 7)
(setq p1 (getpoint "\n指定第一点:"))
(initget 7)
(setq p2 (getpoint p1 "\n指定第二点:"))
(setq tmat (gxl-Mat-Reflect p1 p2))
(setq basept (gxl-MAT-MXP tmat basept)
tmat (vlax-tmatrix tmat)
)
(mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
)
((and MoveFlag
(= 2 (car gr))
(or (= (cadr gr) (ascii "s")) (= (cadr gr) (ascii "S")))
) ;_ 左右翻
(setq tmat (vlax-tmatrix (gxl-Mat-Reflect basept (polar basept pi2 10))))
(mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
)
((and MoveFlag
(= 2 (car gr))
(or (= (cadr gr) (ascii "d")) (= (cadr gr) (ascii "D")))
) ;_ 上下翻
(setq tmat (vlax-tmatrix (gxl-Mat-Reflect basept (polar basept 0 10))))
(mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
)
((and MoveFlag
(= 2 (car gr))
(or (= (cadr gr) (ascii "l")) (= (cadr gr) (ascii "L")))
) ;_ 缩放
(command "_scale" ss "" )
(while (= 1 (logand (getvar 'cmdactive) 1))
(command pause)
)
;|(initget 7 "R")
(setq scale (getdist (trans basept 0 1) "\n指定比例因子或 [参照(R)]:"))
(if (= scale "R")
(progn
(initget 6)
(setq refdis (getdist (trans basept 0 1) "\n指定参照长度 <1>:"))
(if (null refdis)(setq refdis 1.0))
(initget 7)
(setq targetdis (getdist"\n指定目标长度::"))
(setq scale (/ targetdis refdis))
)
)
(setq tmat (vlax-tmatrix (gxl-Mat-Scalebase basept scale)))
(mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)|;
)
((and MoveFlag
(= 2 (car gr))
(or (= (cadr gr) (ascii "f")) (= (cadr gr) (ascii "F")))
) ;_ 对齐
(initget 7)
(setq p1 (getpoint "\n指定源对象第1点:"))
(initget 7)
(setq p3 (getpoint p1 "\n指定目标第1点:"))
(grdraw p1 p3 1 -1)
(initget 7)
(setq p2 (getpoint "\n指定源对象第2点:"))
(initget 7)
(setq p4 (getpoint "\n指定目标第2点:"))
(grdraw p2 p4 1 -1)
(setq p1 (trans p1 1 0))
(setq p2 (trans p2 1 0))
(setq p3 (trans p3 1 0))
(setq p4 (trans p4 1 0))
(setq scale (/ (distance p3 p4) (distance p1 p2)))
(setq tmat (gxl-Mat-TranslateBy2P p1 p3)
tmat (gxl-MAT-MXM
tmat
(gxl-Mat-Rotation p1 (- (angle p3 p4) (angle p1 p2)))
)
)
(initget "Y N")
(setq kd (getkword "是否基于对齐点缩放对象？[是(Y)/否(N)] <否>:"))
(setq kd (= "Y" kd))
(if kd
(setq tmat
(gxl-MAT-MXM
(gxl-Mat-Scalebase p3 scale)
tmat
)
)
)
(if copyflag
(progn
(setq tmp (mapcar 'vla-copy targetObjs))
(setq lastobjs tmp lastbasept (gxl-MAT-MXP tmat basept))
(setq tmat (vlax-tmatrix tmat))
(mapcar '(lambda (x)(vla-TransformBy x tmat)) tmp)
)
(progn
(setq lastobjstargetObjs basept (gxl-MAT-MXP tmat basept))
(mapcar '(lambda (x)(vla-TransformBy x (vlax-tmatrix tmat))) targetObjs)
(mapcar 'vla-delete SourceObjs)
(setq MoveFlag nil)
)
)
)
)
)
)
)
(redraw)
(princ)
)
(princ)
全部源码下载：
顶G版，太给力了 学习下，顶固版。 感谢G版分享程序,下载学习了! 牢固大侠的程序一定要支持！ 本帖最后由 HLCAD 于 2013-9-25 16:35 编辑
发现一个小BUG：命令:
命令: DynDrag
选择物体:
选择对象: 指定对角点: 找到 27 个
选择对象:
选择基点:
[复制<C>/移动<M>]<C>:
**点取位置或 {改基点/改转角/转90度/镜像/左右翻/上下翻/缩放/对齐/}<退出>:_rotate
UCS 当前的正角方向:ANGDIR=逆时针ANGBASE=0.0
选择对象: 找到 0 个
选择对象:
命令: ; 错误: 参数类型错误: 二维/三维点: nil
如果在“[复制<C>/移动<M>]<C>:”这步，在一新位置复制所选实体，再按“R”改转角，则不出错。
頂G版，太給力了 学习下 顶一个 感谢G版分享程序!
G版给力哦。 顶一下，这个强大 本帖最后由 dbx5511 于 2013-10-2 15:09 编辑
这个是非常的不错，稍微有一点小小的瑕疵，就是命令执行的最后一个拷贝的东西，旋转后，会产生一个所拷贝的物体，实际上这个物体是需要的，就是命令最后要终止的时候，动态预览的那个选择集，会落在图上，会产生一组所选来拷贝或者旋转的物体，虚线显示，需要人工取删除。其他的非常好，比天正建筑的自由拷贝还要好。另外一个就是最好拷贝一次后，如果有调整角度（旋转），下一个的动态预览的角度最好是调整后的，现在的预览角度是最初开始拷贝的角度。 12楼的问题是个问题 最近还在用这个插件，感觉如果能在拷贝和旋转中间切换，就更好了，另外一个问题就是如果图纸文件很大的话，有捕捉的时候，操作命令会很卡。 下来学习一下