[原创]：(原代码)保持参照块位置,改块插入点.不用转换矩阵的简便写法

梦断江南

2. 
   
3. ;| c:chbkins = 保持参照块位置,改块插入点(only for 平面块)-----------ok!!完成--------梦断江南.lxx.2004.10
   
4. 支持:wcs,ucs, 不等比参照块.镜像块.
   
5. 命令: chbkins
   
6. |;
   
7. (defun c:chbkins ( / *doc e p000 p1e p1 p2 p2x bkobj ss lst)
   
8.   (while (not(and (princ "\n请选择一个块参照:")
   
9.                   (setq s (ssget ":S:E" '((0 . "INSERT"))))
   
10.   )))
    
11.   (setq *doc (vla-get-activedocument(vlax-get-acad-object))
    
12.         p000 (list 0. 0. 0.)
    
13.         e    (ssname s 0)
    
14.         bkn  (xdxf e 2)                                   ;;块名.
    
15.         p1e  (xdxf e 10)                                  ;;块插入点wcs,dcs.
    
16.         p1   (trans p1e e 1)                              ;;块插入点ucs.
    
17.         p2   (getpoint p1 "\n选择新的块插入点:"))         ;;新插入点ucs.
    
18.   (if p2
    
19.     (progn
    
20.       (setq p2x (x-inspttrans e (trans p2 1 0)) ;;块定义相对位移点.wcs.
    
21.             bkobj (vla-item (vla-get-blocks *doc) bkn)    ;;取得块定义实体.
    
22.             ss          (ssget "x" (list '(0 . "INSERT") (cons 2 (xdxf e 2))))
    
23.       )
    
24.       ;;重新定义块---改插入点.
    
25.       (vlax-for i bkobj (setq lst (cons i lst)))
    
26.       (mapcar '(lambda (x) (vla-move x (ptx p2x) (ptx p000))) lst);;ok!
    
27.       ;;移动块参照,使其位置保持原状.
    
28.       (mapcar '(lambda (x)(vla-move(x2o x)(ptx (xdxf x 10))(ptx (x-insptbak x p2x))))(xss2lst ss))
    
29.     )
    
30.   )
    
31.   (princ)
    
32. )
    
33. ;;********************************************************************************
    
34. ;;(x-inspttrans e pt) = 转换新插入点为原始块定义相对定位点wcs(位移向量)-----ok!
    
35. (defun x-inspttrans (e pt / obj atts attv p ang xs ys zs ) ;;for wcs
    
36.   (setq p000  (list 0. 0. 0.)
    
37.         obj   (vlax-ename->vla-object e)
    
38.         p     (xdxf e 10)
    
39.         atts '(rotation xscalefactor yscalefactor zscalefactor)
    
40.         attv  (mapcar '(lambda(x)(vlax-get obj x)) atts))
    
41.   (mapcar 'set '(ang xs ys zs) attv)
    
42.   (setq pt (polar p000 (- (angle p pt) ang) (distance p pt))
    
43.         pt (mapcar '/ pt (list xs ys zs)))
    
44. )
    
45. ;;********************************************************************************
    
46. ;;根据位移向量pt反求块原来的插入点wcs.------------------ok!
    
47. (defun x-insptbak (e pt / obj atts attv p ang xs ys zs) ;;for wcs
    
48.   (setq p000  (list 0. 0. 0.)
    
49.         p     (xdxf e 10)
    
50.         obj   (vlax-ename->vla-object e)
    
51.         atts '(rotation xscalefactor yscalefactor zscalefactor)
    
52.         attv  (mapcar '(lambda(x)(vlax-get obj x)) atts))
    
53.   (mapcar 'set '(ang xs ys zs) attv)
    
54.   (setq pt (mapcar '* pt (list xs ys zs))
    
55.         pt (polar p (+ (angle p000 pt) ang) (distance p000 pt)))
    
56. )
    
57. ;; 点转换为 vla点.
    
58. (defun ptx (pt)
    
59.   (if (= (type pt) 'variant)
    
60.     pt
    
61.     (vlax-3d-point pt)
    
62.   )
    
63. )
    
64. ;; 取得实体dxf值.
    
65. (defun xdxf (e id)
    
66.   (cdr(assoc id (entget e)))
    
67. )
    
68. ;;(xss2lst ss) = 选集实体名列表.
    
69. (defun xss2lst (ss / i lst)
    
70.   (setq i -1)
    
71.   (while (setq e (ssname ss (setq i (1+ i))))
    
72.     (setq lst (cons (xdxf e -1) lst))
    
73.   )(reverse lst)
    
74. )
    
75. ;;
    
76. (defun x2o (eobj)
    
77.   (if (= 'ENAME (type eobj))
    
78.     (vlax-ename->vla-object eobj)
    
79.     eobj
    
80.   )
    
81. )
    

<br /> ;| c:chbkins = 保持参照块位置,改块插入点(only for 平面块)-----------ok!!完成--------梦断江南.lxx.2004.10<br /> 支持:wcs,ucs, 不等比参照块.镜像块.<br /> 命令: chbkins<br /> |;<br /> (defun c:chbkins ( / *doc e p000 p1e p1 p2 p2x bkobj ss lst)<br />   (while (not(and (princ "\n请选择一个块参照:")<br />                   (setq s (ssget ":S:E" '((0 . "INSERT"))))<br />   )))<br />   (setq *doc (vla-get-activedocument(vlax-get-acad-object))<br />         p000 (list 0. 0. 0.)<br />         e    (ssname s 0)<br />         bkn  (xdxf e 2)                                   ;;块名.<br />         p1e  (xdxf e 10)                                  ;;块插入点wcs,dcs.<br />         p1   (trans p1e e 1)                              ;;块插入点ucs.<br />         p2   (getpoint p1 "\n选择新的块插入点:"))         ;;新插入点ucs.<br />   (if p2<br />     (progn<br />       (setq p2x (x-inspttrans e (trans p2 1 0)) ;;块定义相对位移点.wcs.<br />             bkobj (vla-item (vla-get-blocks *doc) bkn)    ;;取得块定义实体.<br />             ss          (ssget "x" (list '(0 . "INSERT") (cons 2 (xdxf e 2))))<br />       )<br />       ;;重新定义块---改插入点. <br />       (vlax-for i bkobj (setq lst (cons i lst)))<br />       (mapcar '(lambda (x) (vla-move x (ptx p2x) (ptx p000))) lst);;ok! <br />       ;;移动块参照,使其位置保持原状.<br />       (mapcar '(lambda (x)(vla-move(x2o x)(ptx (xdxf x 10))(ptx (x-insptbak x p2x))))(xss2lst ss))<br />     )<br />   )<br />   (princ)<br /> )<br /> ;;********************************************************************************<br /> ;;(x-inspttrans e pt) = 转换新插入点为原始块定义相对定位点wcs(位移向量)-----ok!<br /> (defun x-inspttrans (e pt / obj atts attv p ang xs ys zs ) ;;for wcs<br />   (setq p000  (list 0. 0. 0.)<br />         obj   (vlax-ename->vla-object e)<br />         p     (xdxf e 10)<br />         atts '(rotation xscalefactor yscalefactor zscalefactor)<br />         attv  (mapcar '(lambda(x)(vlax-get obj x)) atts))<br />   (mapcar 'set '(ang xs ys zs) attv)<br />   (setq pt (polar p000 (- (angle p pt) ang) (distance p pt))<br />         pt (mapcar '/ pt (list xs ys zs)))<br /> )<br /> ;;********************************************************************************<br /> ;;根据位移向量pt反求块原来的插入点wcs.------------------ok!<br /> (defun x-insptbak (e pt / obj atts attv p ang xs ys zs) ;;for wcs<br />   (setq p000  (list 0. 0. 0.)<br />         p     (xdxf e 10)<br />         obj   (vlax-ename->vla-object e)<br />         atts '(rotation xscalefactor yscalefactor zscalefactor)<br />         attv  (mapcar '(lambda(x)(vlax-get obj x)) atts))<br />   (mapcar 'set '(ang xs ys zs) attv)<br />   (setq pt (mapcar '* pt (list xs ys zs))<br />         pt (polar p (+ (angle p000 pt) ang) (distance p000 pt)))<br /> )<br /> ;; 点转换为 vla点.<br /> (defun ptx (pt)<br />   (if (= (type pt) 'variant)<br />     pt<br />     (vlax-3d-point pt)<br />   )<br /> )<br /> ;; 取得实体dxf值.<br /> (defun xdxf (e id)<br />   (cdr(assoc id (entget e)))<br /> )<br /> ;;(xss2lst ss) = 选集实体名列表.<br /> (defun xss2lst (ss / i lst)<br />   (setq i -1)<br />   (while (setq e (ssname ss (setq i (1+ i))))<br />     (setq lst (cons (xdxf e -1) lst))<br />   )(reverse lst)<br /> )<br /> ;;<br /> (defun x2o (eobj)<br />   (if (= 'ENAME (type eobj))<br />     (vlax-ename->vla-object eobj)<br />     eobj<br />   )<br /> )<br />

LUCAS

沒有你說的效果  8-(

梦断江南

目前还不支持实体z方向不是0,0,1的情况(dxf210)

aidraft

选择新的块插入点:; 错误: no function definition: X2O

梦断江南

漏了一个函数.已经补上

eachy

2004.10.10 新写的一个，虽然可以用，还不太满意。

http://www.xdcad.net/forum/showt ... 1379476#post1379476

LUCAS

没有测试------所以沒有通過    8-)
嵌套塊要保持位置----想一下都會頭痛

eachy

最初由 LUCAS 发布
[B]没有测试------所以沒有通過    8-)
嵌套塊要保持位置----想一下都會頭痛 [/B]

没有测试，只是说明一个思路，块定义内实体和普通实体一样编辑后更新块引用。

sbzqby

看得头都是大的！怎么办哦。学不会

jx2008

程序很好，谢谢了

pxt2001

楼主没有测试吧，附件中的lisp加载后，运行，命令行提示：no function definition: VLAX-GET-ACAD-OBJECT.

az98hxq

谢谢
终于找到了

TYEEXDD

11楼，你用之前加一个(vl-load-com)就可以了
呵呵 楼上各位前辈的程序待俺好好学习学习 测试一下再说
不过自2006版开始不是增加了动态块的功能吗 可以很方便的调整块的插入点了

哦 原来前辈们是04年发的帖子 才看到日期 惭愧 ：）

hnfsf

嘿嘿，不错，偶尔可以用用