[原创]锁定dim标注数值(支持公差等格式)

mccad

2. ;; dmvl ==锁定dim标注数值==明经通道==2004.3.11.
3. ;;
4. (defun c:dmvl (/ ss i ent e e1 intpnt blkname blk obj txt)
5.    (vl-load-com)
6.    (setq  ss (ssget '((0 . "DIMENSION")))
7.   i   0
8.    )
9.    (repeat (sslength ss)
10.        (setq ent     (ssname ss i)
11.      e     (entget ent)
12.      e1     (cdr (assoc 1 e))
13.      intpnt   (cdr (assoc 11 e))
14.      blkname (cdr (assoc 2 e))
15.      blk     (vla-item (vla-get-blocks
16.                  (vla-get-Activedocument (vlax-get-acad-object))
17.              )
18.              blkname
19.        )
20.        )
21.        (vlax-for obj blk
22.            (if (= (vla-get-objectname obj) "AcDbMText")
23.   (progn
24.      (setq  txt (vla-get-textstring obj)
25.      )
26.      (if (or (= "" e1) (wcmatch e1 "*<>*"))
27.          (progn
28.              (setq e (subst (cons 1 txt) (assoc 1 e) e))
29.              (entmod e)
30.              (entupd ent)
31.          )
32.      )
33.   )
34.            )
35.        )       (setq i (1+ i))
36.    )
37.    (princ)
38. )

;; dmvl ==锁定dim标注数值==明经通道==2004.3.11. ;; (defun c:dmvl (/ ss i ent e e1 intpnt blkname blk obj txt)    (vl-load-com)    (setq  ss (ssget '((0 . "DIMENSION")))   i   0    )    (repeat (sslength ss)        (setq ent     (ssname ss i)      e     (entget ent)      e1     (cdr (assoc 1 e))      intpnt   (cdr (assoc 11 e))      blkname (cdr (assoc 2 e))      blk     (vla-item (vla-get-blocks                  (vla-get-Activedocument (vlax-get-acad-object))              )              blkname        )        )        (vlax-for obj blk            (if (= (vla-get-objectname obj) "AcDbMText")   (progn      (setq  txt (vla-get-textstring obj)      )      (if (or (= "" e1) (wcmatch e1 "*<>*"))          (progn              (setq e (subst (cons 1 txt) (assoc 1 e) e))              (entmod e)              (entupd ent)          )      )   )            )        )       (setq i (1+ i))    )    (princ) )

sunny_8848

谢谢分享，学习了...

wyj_007

双枪手，真厉害！请问VBA程式How to use? 请别见笑，lisp我懂还会编，但VBA到目前为止如同一个娃娃学步的级别。请老师指点三本高级中级低级VBA书籍，在下有礼了，谢谢！ 看样子，这个程序主要功能是把dim标注数值用文字形式固定下来，这样在放大缩小图纸时不必担心尺寸值走样。我以前也编过类似的程序，不过还不够完善。还应有一个逆程序，可以在想要回复时也有办法。

mccad

改回去因为太简单了，所以没有写，你自己试试吧。


VBA的书本来就少，好书就更少了。我们想写，但时间太少，呵呵，手头的书也只写了一点点。


帮助文件是很好的教材，试试吧，论坛也有介绍一些VBA的书，你查查看。

wyj_007

我做过测试了，在CAD2000以上是可以用的，但因为有好多vla-*类语句，在R14下是没办法运行的。但总来讲，程序还是很实用的。

ljcgq

给你个恢复的选择尺寸敲两次空格键就恢复了,当然也可以编辑尺寸文本 ;=================
;修改尺寸文本
;LJC 2004.2
;====================
(DEFUN C:eDD(/ ss n a d i)
(princ "\n选择修改的尺寸")
(princ)
(SETQ SS(SSGET '((0 . "dimension")) ))
(setq n(sslength ss) i 0)
(setq a(getstring "文本修改为:"))
(repeat n
(setq d(entget (ssname ss i)))
(setq d (subst (cons 1 a) (assoc 1 d) d))
(entmod d)
(entupd (ssname ss i))
(setq i (1+ i))
)
)

无痕

为什么不用：

4. 
   
5. (defun c:dmn (/ str)
7. 
   
10. 
    
11.          (vl-cmdf ".dim" "n" (if (setq str (getstring "\n新标注文本&lt;回车＝默认值&gt;:")) str "&lt;&gt;")         (ssget) "" "e")
13. 
    
14. )
16. 
    

<br /> (defun c:dmn (/ str) <br /> <br />          (vl-cmdf ".dim" "n" (if (setq str (getstring "\n新标注文本&lt;回车＝默认值&gt;:")) str "&lt;&gt;")         (ssget) "" "e") <br /> ) <br />

无痕

重发支持r14的标注固定硬改法

2. ;;(getdimtext dimentity) = 取出标注的文本!;;支持所有标注类型.
3. (defun c:dmvl (/ ss n dm dml)
4.    (princ "\ndmvl = 块定义修改法－固定标注文字!   ------by 无痕.2004.3
5. \n选择要固定文字的标注:")
6.    (setq ss (ssget '((0 . "DIMENSION"))))
7.    (repeat (setq n (sslength ss))
8.        (setq dm (ssname ss (setq n (1- n)))
9.      dml(entget dm)
10.      dml(subst (cons 1 (getdimtext dm))(assoc 1 dml) dml))
11.        (entmod dml)
12.    )(princ (strcat "\n共处理" (itoa (sslength ss)) "个标注:"))
13.    (princ)
14. )
15. ;;取标注文本.  
16. (defun getdimtext (ent / dimblk roop e el)
17.    (setq dimblk (cdr (assoc -2 (tblsearch "block" (cdr (assoc 2 (entget ent))))))
18.   roop T)
19.    (while roop
20.        (setq e (entnext e)
21.      el(entget e))
22.        (if (member '(0 . "MTEXT") el)
23.            (setq roop nil)
24.        )
25.    )
26.    (cdr (assoc 1 el))
27. )

;;(getdimtext dimentity) = 取出标注的文本!;;支持所有标注类型. (defun c:dmvl (/ ss n dm dml)    (princ "\ndmvl = 块定义修改法－固定标注文字!   ------by 无痕.2004.3 \n选择要固定文字的标注:")    (setq ss (ssget '((0 . "DIMENSION"))))    (repeat (setq n (sslength ss))        (setq dm (ssname ss (setq n (1- n)))      dml(entget dm)      dml(subst (cons 1 (getdimtext dm))(assoc 1 dml) dml))        (entmod dml)    )(princ (strcat "\n共处理" (itoa (sslength ss)) "个标注:"))    (princ) ) ;;取标注文本.   (defun getdimtext (ent / dimblk roop e el)    (setq dimblk (cdr (assoc -2 (tblsearch "block" (cdr (assoc 2 (entget ent))))))   roop T)    (while roop        (setq e (entnext e)      el(entget e))        (if (member '(0 . "MTEXT") el)            (setq roop nil)        )    )    (cdr (assoc 1 el)) )

wyj_007

谢谢拉!!!过几天上传一个Rotate and copy 程序,特别适用变角度拷贝。现在正在调试。

mccad

wyj_007发表于2004-3-20 14:26:00谢谢拉!!!过几天上传一个Rotate and copy 程序,特别适用变角度拷贝。现在正在调试。

这个其实很简单：

2. ;;复制旋转对象
3. (defun c:cr ()
4.    (setq ent (ssget))
5.    (command "copy" ent "" pause "@" "rotate" "p" "" "@")
6. )

;;复制旋转对象 (defun c:cr ()    (setq ent (ssget))    (command "copy" ent "" pause "@" "rotate" "p" "" "@") )

ljcgq

无痕发表于2004-3-19 23:41:00为什么不用： (defun c:dmn (/ str) (vl-cmdf \".dim\" \"n\" (if (setq str (getstring \"\n新标注文本<回车＝默认值>:\")) str \"<&g...

不好意思,我初学LSP其实对VL是一点都不懂,只是前一段时间刚好需要要这样的东西自己就写了一下翻到这一贴觉得还能用的上就.....,不过还是谢谢您的指点,我会努力的...