[风之影][讨论]块中图元原位复制
因开发需要，现希望广大高手提供思路。要求代码短些，而且操作简单，鼠标单选一下就复制出来，这是风之影推崇的人机工程，花里胡哨的功能就不需要了。ET里有个块中图元复制ncopy，但是操作复杂。aidraft也有一个程序，比ET中的快些，但操作不能满足要求。qjchen也用.net开发了一个，可惜不能在低版本下使用。
本帖最后由 高飞鸟 于 2012-1-2 23:14 编辑
下面的代码不知道可以吗:
(if (null *doc)
(setq *doc (vla-get-activedocument (vlax-get-acad-object)))
)
(defun c:test (/ BLK ENT LX LY LZ MAT OBJ REF RET SCLMAT SX SY SZ TRSMAT VV VX VY VZ new *space)
(setq ret (nentselp))
(if (null ret)
(exit)
)
(setq mat (caddr ret)) ;这个是变换矩阵
(setq vv(reverse (cdr (reverse mat)))) ;去掉第四行(0 0 0 1)
(setq vX(mapcar 'car vv)) ;X 向量
(setq vY(mapcar 'cadr vv)) ;Y 向量
(setq vZ(mapcar 'caddr vv)) ;Z 向量
(setq lX(distance vX '(0 0 0))) ;X 比例因子
(setq lY(distance vY '(0 0 0))) ;Y 比例因子
(setq lZ(distance vZ '(0 0 0))) ;Z 比例因子
(setq ent (car ret))
(setq obj (vlax-ename->vla-object ent))
(if (and (equal lX lY 1e-8) (equal lY lZ 1e-8)) ;如果是均匀缩放
(progn
(if (zerop (vla-get-ActiveSpace *doc))
(setq *space (vla-get-PaperSpace *doc))
(setq *space (vla-get-modelspace *doc))
)
(vlax-invoke *doc 'copyobjects (list obj) *space) ;则仅仅是copyObjects方式添加到空间中
(setq new (vlax-ename->vla-object (entlast)))
(vla-transformby new (vlax-tmatrix mat)) ;然后再矩阵变换
)
(progn
(setq blk (make-anonymous-block obj)) ;先做一个匿名图块
(setq ref (vlax-ename->vla-object (entlast))) ;插入块参照
(setq sX(/ 1 lx)) ;非均匀缩放则要取得各个比例值
(setq sY(/ 1 lY))
(setq sZ(/ 1 lZ))
(setq sclMat (list (list sX 0 0 1) ;乘以一个比例缩放矩阵使得比例均匀
(list 0 sY 0 1)
(list 0 0 sZ 1)
(list 0 00 1)
)
)
(setq trsmat (MAT:mxm mat sclMat)) ;得到一个均匀缩放的变换矩阵
(vla-transformby ref (vlax-tmatrix trsmat)) ;变换参照
;;最后需要变换回去
(vla-put-xscalefactor ref (* (vla-get-xscalefactor ref) lX))
(vla-put-yscalefactor ref (* (vla-get-yscalefactor ref) lY))
(vla-put-zscalefactor ref (* (vla-get-zscalefactor ref) lZ))
(vlax-put ref 'insertionpoint (mapcar 'last vv))
;;(vla-Explode ref)
(command "explode" "L") ;炸开匿名块参照
;;(vla-delete ref)
(vla-delete blk) ;删除匿名块定义
)
)
(princ)
)
;;;-----------------------------------------------------------;;
;;; 匿名块程序 ;;
;;;-----------------------------------------------------------;;
(defun make-anonymous-block(obj / BLKOBJ origin bkName *space)
(setq origin(vlax-3d-point '(0.0 0.0 0.0)))
(setq blkobj (vla-add (vla-get-blocks *doc) origin "*U"))
(setq bkName (vla-get-name blkobj))
(vlax-invoke *doc 'copyobjects (list obj) blkobj)
(if (zerop (vla-get-ActiveSpace *doc))
(setq *space (vla-get-PaperSpace *doc))
(setq *space (vla-get-modelspace *doc))
)
(vla-insertblock *space originbkName 1 1 1 0)
(vla-put-Explodable blkobj :vlax-true)
blkobj
)
;;;-----------------------------------------------------------;;
;;; 矩阵转置 ;;
;;; MAT:trp Transpose a matrix -Doug Wilson- ;;
;;;-----------------------------------------------------------;;
(defun MAT:trp (m)
(apply 'mapcar (cons 'list m))
)
;;;-----------------------------------------------------------;;
;;; 向量的矩阵变换(向量乘矩阵) ;;
;;; Matrix x Vector - Vladimir Nesterovsky ;;
;;; Args: m - nxn matrix, v - vector in R^n ;;
;;;-----------------------------------------------------------;;
(defun MAT:mxv (m v)
(mapcar (function (lambda (r) (apply '+ (mapcar '* r v)))) m)
)
;;;-----------------------------------------------------------;;
;;; 矩阵相乘 ;;
;;; MAT:mxm Multiply two matrices -Vladimir Nesterovsky- ;;
;;;-----------------------------------------------------------;;
(defun MAT:mxm (m q)
(mapcar (function (lambda (r) (MAT:mxv (MAT:trp q) r))) m)
)
本帖最后由 highflybir 于 2012-1-25 20:27 编辑
byghbcx 发表于 2012-1-6 08:16 http://bbs.mjtd.com/static/image/common/back.gif
高飞鸟写的程序有点像HIGHFILYBIRD的风格，该程序对外部参照、嵌套非等比例块、属性文字等内容暂不支持原位 ...
其实对嵌套非等比例块还是支持的，只不过对非正交变换不支持。
lee mac有个cxb命令跟高飞鸟的差不多，不是说谁抄谁。只是说谁先分享出来，高手还是要互相学习啊。框选要用arx，像添加对象到块，原位复制块内对象，都是同样的原理 风大侠也有求助的？
提供一个笨一点的思路:点选后把块信息保存，炸开，原位复制一个点选处的图元，再把炸开的块删除，原位插入原块。复制出来的图元就可以利用了。估计能行，只是对属性块和多重快可能有点麻烦 langjs 发表于 2012-1-1 10:15 static/image/common/back.gif
风大侠也有求助的？
提供一个笨一点的思路:点选后把块信息保存，炸开，原位复制一个点选处的图元，再把炸开 ...
有些块炸不开。操作也复杂，不是我要的 本帖最后由 xianaihua 于 2012-1-1 19:48 编辑
这是别人的一个程序
;; LE
;; 块自动复制：程序复制所选的图块
(setq blkautocopy_on t)
;; local error
(defun blkautocopy-error(g)
(if (not (member g '("console break" "Function cancelled")))
(princ (strcat "\nError: " g)))
(if (and
;; is the ability on?
blkautocopy_on
;; the new block exist?
new_obj
;; has not been erased?
(not (vlax-erased-p new_obj))
;; can we do something to it?
(vlax-write-enabled-p new_obj))
;; erase it
(vla-delete new_obj))
;; turn it nil
(setq new_obj nil)
;; un-highlight our selection
(sssetfirst nil)
(setq *error* olderr)
(princ))
;; 图块拖拽移动
(defun blk-drag-move (msg obj / take code5 p3)
(prompt (strcat "\n"
(cond(msg)
("Move")
)
"\n"
)
)
(while (and (setq take (grread 't 15)) (/= 3 (car take)))
(setq code5(car take)
p3(cadr take)
)
(if(and p3 (= 5 code5))
(vla-move
obj
(vla-get-insertionpoint obj)
(vlax-3d-point p3)
)
)
)
)
;; 复制一个块并移动到新的位置
(defun blkautocopy (reactor params / olderr ss obj new_obj)
(setqolderr*error*
*error*blkautocopy-error
)
(if (and
;; ability is on?
blkautocopy_on
;; no command is in use?
(= (getvar "cmdnames") "")
;; the pickfirst value in on?
(eq 1 (logand 1 (getvar "pickfirst")))
;; are we selecting a block?
(setq ss (ssget "_i" '((0 . "INSERT"))))
;; did we got just one?
(eq 1 (sslength ss))
;; get the ename and convert it into a vla-object
(setq obj (vlax-ename->vla-object (ssname ss 0)))
)
(progn
(prompt "\n正在复制一个块... \n")
;; make a copy of the block
(setq new_obj (vla-copy obj))
;; move the new block to another place
(blk-drag-move "指定第二个位置点: " new_obj)
;; un-highlight our selection
(sssetfirst nil)
)
)
(setq *error* olderr)
)
;; 主反应器
(if (not blkautocopy_reactor)
(setqblkautocopy_reactor
(vlr-miscellaneous-reactor
"blkautocopy block = miscellaneous reactor"
'((:vlr-pickfirstmodified . blkautocopy))
)
)
)
(princ)
围观一下。。。。。。 :) 那我也凑下热闹，帖子可以见此贴
http://bbs.mjtd.com/thread-91589-1-1.html
效果如下
http://qjchen.mjtd.com/wp-content/uploads/2012/01/copyinsideblock.gif
纵观各位高手的程序，只有高飞鸟是按我的要求点击后原位复制的。如果是多个操作步骤的话，我就直接用ET里的ncopy就可以实现。高手们程序虽好，但操作步骤并不比ncopy优化，可见还是没有跳出桌子公司画的圈子。高手们还得在人机工程上狠下功夫，也许这是和高飞鸟的最大差距之一吧。 向高手们学，但楼主也不错 高飞鸟写的程序有点像HIGHFILYBIRD的风格，该程序对外部参照、嵌套非等比例块、属性文字等内容暂不支持原位复制，但对一般块已足够了。