[风之影][讨论]块中图元原位复制

cabinsummer · 发表于 2012-1-1 09:46:13

因开发需要，现希望广大高手提供思路。要求代码短些，而且操作简单，鼠标单选一下就复制出来，这是风之影推崇的人机工程，花里胡哨的功能就不需要了。
ET里有个块中图元复制ncopy，但是操作复杂。aidraft也有一个程序，比ET中的快些，但操作不能满足要求。qjchen也用.net开发了一个，可惜不能在低版本下使用。

高飞鸟 · 发表于 2012-1-2 23:13:35

本帖最后由高飞鸟于 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 0 0 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 origin bkName 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)
)

(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 0  0 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 origin  bkName 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-6 08:51:15

本帖最后由 highflybir 于 2012-1-25 20:27 编辑

byghbcx 发表于 2012-1-6 08:16
高飞鸟写的程序有点像HIGHFILYBIRD的风格，该程序对外部参照、嵌套非等比例块、属性文字等内容暂不支持原位 ...

其实对嵌套非等比例块还是支持的，只不过对非正交变换不支持。

xinxirong · 发表于 2018-7-31 18:57:49

lee mac有个cxb命令跟高飞鸟的差不多，不是说谁抄谁。只是说谁先分享出来，高手还是要互相学习啊。框选要用arx，像添加对象到块，原位复制块内对象，都是同样的原理

langjs · 发表于 2012-1-1 10:15:26

风大侠也有求助的？
提供一个笨一点的思路:点选后把块信息保存，炸开，原位复制一个点选处的图元，再把炸开的块删除，原位插入原块。复制出来的图元就可以利用了。估计能行，只是对属性块和多重快可能有点麻烦

cabinsummer · 发表于 2012-1-1 10:22:34

langjs 发表于 2012-1-1 10:15
风大侠也有求助的？
提供一个笨一点的思路:点选后把块信息保存，炸开，原位复制一个点选处的图元，再把炸开 ...

有些块炸不开。操作也复杂，不是我要的

xianaihua · 发表于 2012-1-1 19:47:34

本帖最后由 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)
(setq olderr *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)
(setq blkautocopy_reactor
(vlr-miscellaneous-reactor
"blkautocopy block = miscellaneous reactor"
'((:vlr-pickfirstmodified . blkautocopy))
)
)
)
(princ)

;; 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) 
  (setq  olderr  *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) 
  (setq  blkautocopy_reactor 
   (vlr-miscellaneous-reactor 
     "blkautocopy block = miscellaneous reactor" 
     '((:vlr-pickfirstmodified . blkautocopy)) 
   ) 
  ) 
) 
(princ)

江湖远人 · 发表于 2012-1-1 22:31:56

围观一下。。。。。。

qjchen · 发表于 2012-1-3 09:42:23

:) 那我也凑下热闹，帖子可以见此贴

http://bbs.mjtd.com/thread-91589-1-1.html

效果如下

cabinsummer · 发表于 2012-1-3 10:24:39

纵观各位高手的程序，只有高飞鸟是按我的要求点击后原位复制的。如果是多个操作步骤的话，我就直接用ET里的ncopy就可以实现。高手们程序虽好，但操作步骤并不比ncopy优化，可见还是没有跳出桌子公司画的圈子。高手们还得在人机工程上狠下功夫，也许这是和高飞鸟的最大差距之一吧。

jfxia · 发表于 2012-1-5 19:58:24

向高手们学，但楼主也不错

byghbcx · 发表于 2012-1-6 08:16:28

高飞鸟写的程序有点像HIGHFILYBIRD的风格，该程序对外部参照、嵌套非等比例块、属性文字等内容暂不支持原位复制，但对一般块已足够了。

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

[风之影][讨论]块中图元原位复制

评分