[原创]：简单的块内实体复制---Block OCS->WCS

eachy · 发表于 2004-9-16 07:27:35

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(defun c:bcopy (/ e el)
(while (and (setq e (nentselp "\n选择块内实体: "))
(= (length e) 4)
)
(setq el (entget (car e)))
(entmake el)
(vla-transformby
(vlax-ename->vla-object (entlast))
(vlax-tmatrix (caddr e))
)
)
(princ)
)

LUCAS · 发表于 2004-9-16 11:16:31

;;以前就發現的問題!
nentselp 對ployline & 屬性會有問題

eachy · 发表于 2004-9-16 12:20:21

最初由 LUCAS 发布
[B];;以前就發現的問題!
nentselp 對ployline & 屬性會有問題 [/B]

可能还需要转换，很久没有用矩阵了，快忘完了，又写个小的片断

;;矩阵应用之块添实体, 利用 nentselp 返回矩阵的逆矩阵往块内添加实体
;;演示中逆矩阵采用了 XDAPI 函数，其Lisp实现函数请搜索论坛以前帖子
(defun c:test (/ bn ss bname blk ssl mat e typ obj doc)
(if (and
(setq bn (nentselp "\n拾取图块: "))
(= (length bn) 4) ;块
(progn
(princ "\n选择添加实体...")
(setq ss (ssget '((0 . "line,circle"))))
)
);end and 条件
(progn
(setq bname (cdr (assoc 2 (entget (last (last bn)))));获取块名
blk (vla-item (vla-get-blocks
(setq doc (vla-get-activedocument
(vlax-get-acad-object)
)
)
)
bname
);获取块定义BlockDeference
ssl (sslength ss)
mat (xdrx_matrix_inverse (caddr bn));获取 WCS -> OCS 矩阵
);end setq
(while (> ssl 0)
(setq e (vlax-ename->vla-object (ssname ss (setq ssl (1- ssl))))
typ (vla-get-objectname e)
)
(vla-transformby e (vlax-tmatrix mat));变换到块定义的UCS
(if (= typ "AcDbLine");块内添加实体
(vla-addline
blk
(vla-get-startpoint e)
(vla-get-endpoint e)
)
(vla-addcircle blk (vla-get-center e) (vla-get-radius e))
);end if
(vla-delete e);删除选择
);end while
(vla-regen doc acActiveviewport);更新Insert (BlockReference)
);end progn
);end if
(princ)
)

;;矩阵应用之块添实体, 利用 nentselp 返回矩阵的逆矩阵往块内添加实体 
;;演示中逆矩阵采用了 XDAPI 函数，其Lisp实现函数请搜索论坛以前帖子 
(defun c:test (/ bn ss bname blk ssl mat e typ obj doc) 
  (if (and 
        (setq bn (nentselp "\n拾取图块: ")) 
        (= (length bn) 4)                ;块 
        (progn 
          (princ "\n选择添加实体...") 
          (setq        ss (ssget '((0 . "line,circle")))) 
        ) 
      );end and 条件 
    (progn 
      (setq bname (cdr (assoc 2 (entget (last (last bn)))));获取块名 
            blk          (vla-item (vla-get-blocks 
                              (setq doc        (vla-get-activedocument 
                                          (vlax-get-acad-object) 
                                        ) 
                              ) 
                            ) 
                            bname 
                  );获取块定义BlockDeference 
            ssl          (sslength ss) 
            mat          (xdrx_matrix_inverse (caddr bn));获取 WCS -> OCS 矩阵 
      );end setq 
      (while (> ssl 0) 
        (setq e          (vlax-ename->vla-object (ssname ss (setq ssl (1- ssl)))) 
              typ (vla-get-objectname e) 
        ) 
        (vla-transformby e (vlax-tmatrix mat));变换到块定义的UCS 
        (if (= typ "AcDbLine");块内添加实体 
          (vla-addline 
            blk 
            (vla-get-startpoint e) 
            (vla-get-endpoint e) 
          ) 
          (vla-addcircle blk (vla-get-center e) (vla-get-radius e)) 
        );end if 
        (vla-delete e);删除选择 
      );end while 
      (vla-regen doc acActiveviewport);更新Insert (BlockReference) 
    );end progn 
  );end if 
  (princ) 
)

梦断江南 · 发表于 2004-9-16 20:10:38

如果是交互式的操作，我觉得双击进入参照块编辑也挺方便。

aidraft · 发表于 2004-9-16 21:29:50

;;; 凑凑热闹:)
;;; 将图块里的图元拷贝到Model Space
;;; 对polyline和nested block有效, attributes则生成texts
;;; dimension不要试,匿名块不详.
(defun C:BC (/ objlst attlst InsertENameHold sel InsertEName EName attEName mirrtext_Hold doc mspace)
(setq mirrtext_Hold (getvar "MIRRTEXT"))
(setvar "MIRRTEXT" 1)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
mspace (vla-get-modelspace doc)
)
(while (setq sel (nentselp "\n选择图块内的图元: "))
(if (= (length sel) 4)
(progn
(setq InsertEName (last (last sel)))
(if (> (length (last sel)) 1)
(setq EName (nth 1 (reverse (last sel))))
(if (= (dxf 0 (entget (car sel))) "VERTEX")
(setq EName (dxf 330 (entget (car sel))))
(setq EName (car sel))
)
) ; end if
) ; progn
(if (/= (dxf 0 (entget (car sel))) "ATTRIB")
(alert "选择的不是图块内的图元.")
(progn
(princ "\n选择了属性...")
(setq attEName (car sel)
InsertEname (dxf 330 (entget attEName))
)
) ; progn
) ; end if
) ; end if
(if (and
InsertENameHold
(not (eq InsertENameHold InsertEName))
)
(alert "不允许选择另一个块内的图元。")
(progn
(setq InsertENameHold InsertEName)
(if (and
EName
(not (member EName objlst))
)
(setq objlst (cons (vlax-ename->vla-object EName) objlst))
) ; end if
(if (and
attEName
(not (member attEName attlst))
)
(setq attlst (cons attEName attlst))
) ; end if
) ; progn
) ; end if
) ; while
(if attlst
(foreach att attlst
(att->text att)
)
)
(setq Mat (InsertMat InsertENameHold))
(if objlst
(progn
(setq retObjs (vla-copyobjects doc (vlax-safearray-fill (vlax-make-safearray vlax-vbObject (cons 0 (1-
(length objlst)
)
)
) objlst
) mspace
)
)
(foreach obj (vlax-safearray->list (vlax-variant-value retobjs))
(vla-transformby obj (vlax-tmatrix Mat))
)
)
)
(setvar "MIRRTEXT" mirrtext_Hold)
(vlax-release-object doc)
(vlax-release-object mspace)
(princ)
)
;;;
;;; THE FOLLOWING CODES ARE MODIFIED FROM JON FLEMING'S FAMOUS BIXform.lsp
;;; to get the 4X4 Transformation matrix from OCS of Block Reference to WCS
;;; Modified by AIDraft 16/9/2004
(defun InsertMat (InsertEname / InsertEList ZAxis NCSXAxis InsertAngle tmp1 tmp2)
(setq ZAxis (cdr (assoc 210 (setq InsertEList (entget InsertEName))))
InsertAngle (cdr (assoc 50 InsertEList))
NCSXAxis (trans (list (cos InsertAngle) (- (sin InsertAngle)) 0.0) (cdr (assoc 210 InsertEList)) 0) ; _ end trans
) ; _ end setq
; Set up the return value
; The insertion point of the insert
(setq tmp1 (trans (cdr (assoc 10 InsertEList)) ZAxis 0)) ; The scale factors
(setq tmp2 (list (cdr (assoc 41 InsertEList)) (cdr (assoc 42 InsertEList)) (cdr (assoc 43 InsertEList))) ; _ end list
)
(list (append
(mapcar
'*
NCSXAxis
tmp2
)
(list (nth 0 tmp1))
) (append
(mapcar
'*
(VectorCrossProduct ZAxis NCSXAxis)
tmp2
)
(list (nth 1 tmp1))
) (append
(mapcar
'*
ZAxis
tmp2
)
(list (nth 2 tmp1))
) '(0.0 0.0 0.0 1.0)
) ; _ end list
)
;;; _ end defun
;;; Vector cross product function
;;; Argument: Two lists, each of three real numbers defining
;;; a vector in 3-space
;;; Return value: A list of three real numbers containing
;;; the first argument crossed with the second argument.
(defun VectorCrossProduct (InputVector1 InputVector2)
(list (- (* (cadr InputVector1) (caddr InputVector2)) (* (cadr InputVector2) (caddr InputVector1))) ; _ end -
(- (* (caddr InputVector1) (car InputVector2)) (* (caddr InputVector2) (car InputVector1))) ; _ end -
(- (* (car InputVector1) (cadr InputVector2)) (* (car InputVector2) (cadr InputVector1))) ; _ end -
) ; _ end list
)
;;; _ end defun
;;;
(defun att->text (attEN / attEL)
(setq attEL (entget attEN))
(entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") (cons 8 (dxf 8 attEL)) '(100 . "AcDbText") (cons 10 (dxf 10 attEL))
(cons 40 (dxf 40 attEL)) (cons 1 (dxf 1 attEL)) (cons 50 (dxf 50 attEL)) (cons 41 (dxf 41 attEL))
(cons 51 (dxf 51 attEL)) (cons 7 (dxf 7 attEL)) (cons 71 (dxf 71 attEL)) (cons 72 (dxf 72 attEL))
(cons 11 (dxf 11 attEL)) (cons 210 (dxf 210 attEL)) '(100 . "AcDbText") (cons 73 (dxf 73 attEL))
) ; list
)
)
;;;
(defun dxf (code elist)
(cdr (assoc code elist))
)

;;; 凑凑热闹:) 
;;; 将图块里的图元拷贝到Model Space 
;;; 对polyline和nested block有效, attributes则生成texts 
;;; dimension不要试,匿名块不详. 
(defun C:BC (/ objlst attlst InsertENameHold sel InsertEName EName attEName mirrtext_Hold doc mspace) 
  (setq mirrtext_Hold (getvar "MIRRTEXT")) 
  (setvar "MIRRTEXT" 1) 
  (setq doc (vla-get-activedocument (vlax-get-acad-object)) 
        mspace (vla-get-modelspace doc) 
  ) 
  (while (setq sel (nentselp "\n选择图块内的图元: ")) 
    (if (= (length sel) 4) 
      (progn 
        (setq InsertEName (last (last sel))) 
        (if (> (length (last sel)) 1) 
          (setq EName (nth 1 (reverse (last sel)))) 
          (if (= (dxf 0 (entget (car sel))) "VERTEX") 
            (setq EName (dxf 330 (entget (car sel)))) 
            (setq EName (car sel)) 
          ) 
        )                               ; end if 
      )                                       ; progn 
      (if (/= (dxf 0 (entget (car sel))) "ATTRIB") 
        (alert "选择的不是图块内的图元.") 
        (progn 
          (princ "\n选择了属性...") 
          (setq attEName (car sel) 
                InsertEname (dxf 330 (entget attEName)) 
          ) 
        )                               ; progn 
      )                                       ; end if 
    )                                       ; end if 
    (if (and 
          InsertENameHold 
          (not (eq InsertENameHold InsertEName)) 
        ) 
      (alert "不允许选择另一个块内的图元。") 
      (progn 
        (setq InsertENameHold InsertEName) 
        (if (and 
              EName 
              (not (member EName objlst)) 
            ) 
          (setq objlst (cons (vlax-ename->vla-object EName) objlst)) 
        )                               ; end if 
        (if (and 
              attEName 
              (not (member attEName attlst)) 
            ) 
          (setq attlst (cons attEName attlst)) 
        )                               ; end if 
      )                                       ; progn 
    )                                       ; end if 
  )                                       ; while 
  (if attlst 
    (foreach att attlst 
      (att->text att) 
    ) 
  ) 
  (setq Mat (InsertMat InsertENameHold)) 
  (if objlst 
    (progn 
      (setq retObjs (vla-copyobjects doc (vlax-safearray-fill (vlax-make-safearray vlax-vbObject (cons 0 (1- 
                                                                                                             (length objlst) 
                                                                                                         ) 
                                                                                                 ) 
                                                              ) objlst 
                                         ) mspace 
                    ) 
      ) 
      (foreach obj (vlax-safearray->list (vlax-variant-value retobjs)) 
        (vla-transformby obj (vlax-tmatrix Mat)) 
      ) 
    ) 
  ) 
  (setvar "MIRRTEXT" mirrtext_Hold) 
  (vlax-release-object doc) 
  (vlax-release-object mspace) 
  (princ) 
) 
;;; 
;;; THE FOLLOWING CODES ARE MODIFIED FROM JON FLEMING'S FAMOUS BIXform.lsp 
;;; to get the 4X4 Transformation matrix from OCS of Block Reference to WCS 
;;; Modified by AIDraft  16/9/2004 
(defun InsertMat (InsertEname / InsertEList ZAxis NCSXAxis InsertAngle tmp1 tmp2) 
  (setq ZAxis (cdr (assoc 210 (setq InsertEList (entget InsertEName)))) 
        InsertAngle (cdr (assoc 50 InsertEList)) 
        NCSXAxis (trans (list (cos InsertAngle) (- (sin InsertAngle)) 0.0) (cdr (assoc 210 InsertEList)) 0) ; _ end trans 
  )                                       ; _ end setq 
                                       ; Set up the return value 
                                       ; The insertion point of the insert 
  (setq tmp1 (trans (cdr (assoc 10 InsertEList)) ZAxis 0)) ; The scale factors 
  (setq tmp2 (list (cdr (assoc 41 InsertEList)) (cdr (assoc 42 InsertEList)) (cdr (assoc 43 InsertEList))) ; _ end list 
  ) 
  (list (append 
          (mapcar 
            '* 
            NCSXAxis 
            tmp2 
          ) 
          (list (nth 0 tmp1)) 
        ) (append 
            (mapcar 
              '* 
              (VectorCrossProduct ZAxis NCSXAxis) 
              tmp2 
            ) 
            (list (nth 1 tmp1)) 
          ) (append 
              (mapcar 
                '* 
                ZAxis 
                tmp2 
              ) 
              (list (nth 2 tmp1)) 
            ) '(0.0 0.0 0.0 1.0) 
  )                                       ; _ end list 
) 
;;; _ end defun 
;;; Vector cross product function 
;;; Argument: Two lists, each of three real numbers defining 
;;; a vector in 3-space 
;;; Return value:  A list of three real numbers containing 
;;; the first argument crossed with the second argument. 
(defun VectorCrossProduct (InputVector1 InputVector2) 
  (list (- (* (cadr InputVector1) (caddr InputVector2)) (* (cadr InputVector2) (caddr InputVector1))) ; _ end - 
        (- (* (caddr InputVector1) (car InputVector2)) (* (caddr InputVector2) (car InputVector1))) ; _ end - 
        (- (* (car InputVector1) (cadr InputVector2)) (* (car InputVector2) (cadr InputVector1))) ; _ end - 
  )                                       ; _ end list 
) 
;;; _ end defun 
;;; 
(defun att->text (attEN / attEL) 
  (setq attEL (entget attEN)) 
  (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") (cons 8 (dxf 8 attEL)) '(100 . "AcDbText") (cons 10 (dxf 10 attEL)) 
                 (cons 40 (dxf 40 attEL)) (cons 1 (dxf 1 attEL)) (cons 50 (dxf 50 attEL)) (cons 41 (dxf 41 attEL)) 
                 (cons 51 (dxf 51 attEL)) (cons 7 (dxf 7 attEL)) (cons 71 (dxf 71 attEL)) (cons 72 (dxf 72 attEL)) 
                 (cons 11 (dxf 11 attEL)) (cons 210 (dxf 210 attEL)) '(100 . "AcDbText") (cons 73 (dxf 73 attEL)) 
           )                               ; list 
  ) 
) 
;;; 
(defun dxf (code elist) 
  (cdr (assoc code elist)) 
)

zb_lou · 发表于 2004-9-18 14:33:00

其实ACAD-bouns有一个很好的程序ncopy。可以在块、参照上复制物体,我经常用，很方便。（可以在R14上用）拷上来给大家参考参考

userzhluserzhl · 发表于 2005-5-1 14:21:35

我试了不行!!!

whj1102 · 发表于 2005-5-21 14:29:31

块内实体复制,很诱人啊,怎么用?

80861819 · 发表于 2005-9-28 17:00:58

先谢谢了,但我试了以后出现 bc ; 错误: no function definition: VLAX-GET-ACAD-OBJECT

请问这是怎么回事呀,
我是用2005的

jx2008 · 发表于 2009-2-10 09:09:12

不适用于不等比例缩放的块

(defun c:bcopy (/ e el ss p1)
(setq ss (ssadd))
(while (and (setq e (nentselp "\n选择块内实体: "))
(= (length e) 4)
)
(setq el (entget (car e)))
(entmake el)
;(vla-transformby ;该函数不能用于不等比例缩放的实体对象
; (vlax-ename->vla-object (entlast))
;(vlax-tmatrix (caddr e))
;)
(setq ss (ssadd (entlast) ss))
)
(if (and SS (/= (sslength SS) 0))
(progn
(if (setq P1 (getpoint "\n指定基点 <原位置>: "))
(progn
(command "_.move" SS "" "_non" P1)
(princ "指定第二点: ")
(command "\")
)
)
(command "_.select" SS "")
)
)
(princ)
)

mmmm · 发表于 2009-2-11 09:51:16

最保险而且安全的方法还得是把块临时炸开，这样块的不等比、旋转、镜像统统不用去考虑了。再NENTSELP选中实体，复制一个。而后恢复图块。

fl202 · 发表于 2009-2-18 09:08:07

想问下如何修改属性块中的文字内容？

bloodmao · 发表于 2009-3-2 20:06:29

学习ING...........

ywqq · 发表于 2009-3-3 08:10:10

谢谢了，
学习学习来。

yinjake007 · 发表于 2009-3-26 21:15:27

都不会用

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

[原创]：简单的块内实体复制---Block OCS->WCS

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子