这个是我最近做的一个修改尺寸文本的源代码。
(defun clerr (s)(if (/= s "Function cancelled")
(princ (strcat "\nError: " s))
)
(setvar "DIMSCALE" dims)
(setvar "CMDECHO"scmde)
(setq *error*olderr)
(princ)
)
；发生ESC H或者CTOL_C的中断处理
(defun C:bzxg()
(setq olderr *error*
*error* clerr)
(setq scmde (getvar "CMDECHO" ))
(setq dims (getvar "DIMSCALE"))
(setvar "cmdecho" 0)
(while (/= (getvar "cmdecho") 0)
(setvar "cmdecho" 0)
)
(princ "\n尺寸修改(zhaoy 2002/10/14)")
(setq contr 1)
(while (= contr 1)；循环操作用法
；ENTSEL 函数
(setq obj (car (entsel "\n请选择需要修改的标注线")))
(setq obj_temp obj)
(if (/= obj nil)
(progn
；ENTGET函数
(setq obj (entget obj))
；ASSOC函数
(if (= (cdr (assoc 0 obj)) "DIMENSION") (setq contr 0))
))
)
(setq tstyle (car (list (cdr (assoc 3 obj)))))
(if (= (substr tstyle 1 5) "STAND")
(progn
(setq obj (subst (cons 3 "STANDARD") (assoc 3 obj) obj))
(entmod obj)
)
)
(setq txt (cdr (assoc 1 obj))
p1 (cdr (assoc 10 obj))
p2 (cdr (assoc 14 obj))
p3 (cdr (assoc 13 obj)))
;dimdec系统变量
(setq tt (getvar "dimdec"));tt为尺寸精度
(if (= txt "")
(progn
；getword函数用法
(initget "YesNo")
(setq kw (getkword "\n不使用原尺寸(N)/<使用原尺寸(Y)>:"))
(COND
((= KW "No")
(setq txt_y (getreal "\n输入标注尺寸值：" ))
)
(t
(setq p2 (inters p2 p1 p3 (polar p3 (+ (angle p2 p1) (/ pi 2.0)) 10) nil))
(setq txt (distance p2 p3));取得尺寸值
(setq txt_y txt)
)
))
(progn
(princ "\n此标注已经被修改过，程序不敢确认是正确的，要求您重新输入：" )
(setq txt_y (getreal "\n输入标注尺寸值：" ))
))
;;以上为选择要修改的尺寸并把尺寸值进行精确的计算
(setq z_txt (rtos txt_y 2 tt))
(setq jiej (getreal "\n输入节距："))
(setq gshu(/ txt_y jiej))
(setq gshu(rtos gshu 2 ))
(setq jiej(rtos jiej 2 1)) ;转化为字符串
(setq txtf (strcatgshu"×"jiej "=" z_txt))
；entmode函数使用
(setq ed (entget obj_temp))
(setq ed (subst (cons 1 txtf) (assoc 1 ed) ed))
(entmod ed)
(setvar "DIMSCALE" dims)
(setvar "CMDECHO"scmde)
(setq *error*olderr)
(princ)
)
此程序对您可能没多大的用处，我认为里面包含了几个很常用的函数的用法。如果有好的建议可以提出来，大家来帮我把它维护的更好，谢谢了。 ;;如尺寸值與文本一致，則文本不變色，否則文本被修改但顏色<BR>;;變如紅色，這樣用戶對這個功能會更好理解也容易維護。 <BR>;;BY LUCAS<BR>(defun C:TT (/ SS N VOBJ)<BR> (setq SS (ssget "X" '((0 . "DIMENSION")))<BR> N 0<BR> )<BR> (repeat (sslength SS)<BR> (setq VOBJ (vlax-ename->vla-object (ssname SS N)))<BR> (if (and VOBJ<BR> (vlax-read-enabled-p VOBJ)<BR> (not (wcmatch (vla-get-textoverride VOBJ) "*<>*,"))<BR> (vlax-write-enabled-p VOBJ)<BR> )<BR> (vla-put-textcolor VOBJ 1)<BR> )<BR> (setq N (1+ N))<BR> )<BR> (princ)<BR>) 非常棒的程序代码，很好的资料，谢谢楼主分享的资料。 很实用的程序，多谢大家的分享
1
(defun B_TOLERANCE_READ_TXT;读出尺寸的大小(
/
B_dim_name;和所选尺寸相对应的块名
B_dim_txt;尺寸文本(CHR)
B_dim_sset;和所选尺寸相对应的块的子实体名
B_dim_length;尺寸文本的长度
B_dim_txt_str;中间字符串变量
B_dim_txt_no;中间计数变量
B_dim_txt_chr;中间字符变量
)
(if (/= (cdr (assoc 0 B_dim_ent)) "DIMENSION")
(progn
(prompt "\n这不是个尺寸标注")
(setq B_dim_choose -1)
);end-progn当不是尺寸标注时由B_dim_choose判断
(progn
(setq B_dim_or (cdr (assoc 1 B_dim_ent)));当是自动生成的尺寸文本时为空
(setq B_dim_name (cdr (assoc 2 B_dim_ent)));读出同名的块名
(setq B_dim_sset (cdr (assoc -2 (tblsearch "BLOCK" B_dim_name))));找块的实体名
(while (/= (cdr (assoc 0 (entget B_dim_sset))) "MTEXT")
(setq B_dim_sset (entnext B_dim_sset))
);end-while寻找写有尺寸大小文本的子实体
(setq B_dim_txt (cdr (assoc 1 (entget B_dim_sset))));读出尺寸大小文本
(setq B_dim_height (cdr (assoc 40 (entget B_dim_sset))))
(setq B_dim_length (strlen B_dim_txt));读出尺寸大小文本的长度
(if (= (substr B_dim_txt 4 1) ";")
(progn
(setq B_dim_length (- B_dim_length 4))
(setq B_dim_txt (substr B_dim_txt 5 B_dim_length))
);end-progn
);end-if去掉读出的尺寸文本的前缀
(cond
((= (substr B_dim_txt 1 1) "r")
(setq B_dim_length (- B_dim_length 1))
(setq B_dim_txt (substr B_dim_txt 2 B_dim_length))
);end-1
((= (substr B_dim_txt 1 1) "R")
(setq B_dim_length (- B_dim_length 1))
(setq B_dim_txt (substr B_dim_txt 2 B_dim_length))
);end-1
((= (substr B_dim_txt 1 1) "m")
(setq B_dim_length (- B_dim_length 1))
(setq B_dim_txt (substr B_dim_txt 2 B_dim_length))
);end-1
((= (substr B_dim_txt 1 1) "M")
(setq B_dim_length (- B_dim_length 1))
(setq B_dim_txt (substr B_dim_txt 2 B_dim_length))
);end-1
((= (substr B_dim_txt 2 6) "U+2205")
(setq B_dim_length (- B_dim_length 7))
(setq B_dim_txt (substr B_dim_txt 8 B_dim_length))
);end-1
);end-cond
(setq B_dim_txt_str "")
(setq B_dim_txt_no B_dim_length)
(while (> B_dim_txt_no 0)
(setq B_dim_txt_no (1- B_dim_txt_no))
(setq B_dim_txt_chr (substr B_dim_txt (- B_dim_length B_dim_txt_no) 1))
(if (/= B_dim_txt_chr ",")
(setq B_dim_txt_str (strcat B_dim_txt_str B_dim_txt_chr))
);end-if
);end-while
(setq B_dim_txt B_dim_txt_str);去掉尺寸文本里的","
(setq B_dim_size (atof B_dim_txt))
(if (> B_dim_size 3150.0)
(progn
(if (null B_ERROR) (load "B_ERROR"))
(B_ERROR "超出程序设计范围,本程序无法计算,请查标准公差手册标注")
(setq B_dim_choose -2)
);end-progn
);end-if
);end-progn
);end-if
);B_TOLERANCE_READ_TXT
大家看看
来看看，这是我写的，是不是更简单一些呢？
(setq txt1 "3000")(defun editdim ()
(princ "\n选择需修改的标注 :")
(setq p (ssget))
(command "dimedit" "n" dim2 "p" "")
(setvar "cmdecho" 1)
)
(defun editdimh ()
(princ "\n选择需修改的标注 :")
(setq p (ssget))
(command "dimedit" "h" "p" "")
(setvar "cmdecho" 1)
)
(defun c:de (/ dim1 p dim2)
(setvar "cmdecho" 0)
(princ "\n请输入标注字符,允许汉字和空格。(空格->还原)(空回车->缺省值)<")
(princ txt1)
(setq dim1 (getstring T ">:"))
(cond
((= dim1 " ")(editdim))
((= dim1 "")(setq dim2 txt1)(editdim))
((= dim1 "H")(editdimh))
((setq txt1 dim1)(setq dim2 dim1)(editdim))
)
) leeyeafu的程序怎么用啊？ 如果多的无用注释，如：
；ENTSEL函数
；ASSOC函数
没有必要的语句
(setvar "cmdecho" 0)
(while (/= (getvar "cmdecho") 0) (setvar "cmdecho" 0))
全部使用全局变量
....
努力，再努力。 有用vba写的么 如尺寸值与文本一致，则文本不变色，否则文本被修改但颜色变如红色，这样用户对这个功能会更好理解也容易维护。 楼上这个提法有点意思 一个正命令：如尺寸值与文本一致，则文本不变色，否则文本被修改但颜色变如红色，并报改了的和不改的统计数据，这样用户对这个功能会更好理解也容易维护。
另一个反命令：当需要改文本为尺寸值，如文本与尺寸值一致，则改过来,否则文本不被修改但颜色变如黄色，并报改了的和不改的统计数据。
有没有R14下的lisp反命令。