怎么没有二次开发的？
比如比例问题，图纸比例不是1：1，单行文字，多行文字的字高要改变，表注箭头、字高要改变，画图中途改变比例，所有的要改变样式吗？有没有一个小程序一次搞定？
我抛个砖等着玉
下面的程序放到：ACA.LSP文件中，执行命令：BL，按提示Scale factor:输入值，即可改变全部文字的字高注意：标题块、图框最好作成图块，不然它们中的字字高也变了！！！！！！！！
(defun c:bl()
(setq val (getreal "Scale factor: "))
;;默认文字字高4.0mm
(setq high (* 4 val))
(setq ssl (ssget "X" (list (cons 0 "MTEXT"))))
(setq N (- (sslength ssl) 1))
(setq test 0)
(while (<= testN )
(setq DIMENSION (ENTGET (ssname ssl test)))
(setq DIMENSION (subst (cons 40 high) (assoc 40 DIMENSION) DIMENSION ))
(entmod DIMENSION)
(setq test (+ 1 test))
)
(setq ssl (ssget "X" (list (cons 0 "TEXT"))))
(setq N (- (sslength ssl) 1))
(setq test 0)
(while (<= testN )
(setq DIMENSION (ENTGET (ssname ssl test)))
(setq DIMENSION (subst (cons 40 high) (assoc 40 DIMENSION) DIMENSION ))
(entmod DIMENSION)
(setq test (+ 1 test))
)
) 确实比较少。原来论坛有相关版块的，因为参与的人少，撤掉了。现在作为一个分类
http://www.askcad.com/bbs/forumdisplay.php?fid=5&filter=type&typeid=4
我抛个砖等着玉
下面的程序放到：ACA.LSP文件中，执行命令：DIMBL，按提示Scale factor:输入值，即可改变全部标注文字的字高、箭头的大小。(defun c:DIMbl()
(setq val (getreal "Scale factor: "))
(setvar "DIMSCALE" val)
(setvar "DIMASZ" 2)
(setvar "DIMTXT" 3.5)
(setq ssl (ssget "X" (list (cons 0 "DIMENSION"))))
(command "dim" "update" ssl "" "exit")
(setq ssl (ssget "X" (list (cons 0 "LEADER"))))
(command "dim" "update" ssl "" "exit")
)
我再抛个砖等着玉
:'(剖面线由于比例不统一，有的太密，有的太稀。下面的程序可以把全部剖面线比例统一。
(defun c:HCbl()
(setq val (getreal "Scale factor: "))
(setq ssl (ssget "X" (list (cons 0 "HATCH"))))
(setq N (- (sslength ssl) 1))
(setq test 0)
(while (<= testN )
(setq SS NIL)
(setq ss (ssadd))
(ssadd (ssname ssl test) SS)
(command "-hatchedit" ss "" "" val "")
(setq test (+ 1 test))
)
)
砖要抛没了！！！！！！！
玉还不出来吗？
:'( :'( :'(
我再抛个砖等着玉
我做图时习惯把虚线、点划线、双点划线分别放在单独的图层，由于粘贴的图形导致同一线形的线形比例不同，很难看，下面的程序可以把选中的线所在图层的全部图线的线形比例统一(defun c:LSbl()
(setqDIMENSION (entget (car (entsel "Please choose an object:" ))))
(setq val (getreal "New linetype Scale : "))
(setq TEXT (cdr (assoc '8 DIMENSION)))
(setq ssl (ssget "X" (list (cons 8 TEXT))))
(command "ChPROP" ssl "" "S"val "")
)
我自说自话
有的时候，打剖面线，有些中心线、虚线、双点划线、序号指引线捣乱，要多选几个剖面区域，下面的程序可以把那些捣乱的线所在的图层冻结。(defun c:FreezeMe()
(setqDIMENSION (entget (car (entsel "Please choose an object:" ))))
(setq TEXT (cdr (assoc '8 DIMENSION)))
(setq Cname (getvar "clayer"))
(if(/= Cname TEXT)
(command "layer" "F" TEXT "")
(progn
(setq templist (tblnext "LAYER" T))
(while templist
(setq name (cdr (assoc 2 templist)))
(if(/= name TEXT)
(progn
(setvar "clayer" name)
(command "layer" "F" TEXT "")
(setq templist nil)
)
(setq templist (tblnext "LAYER"))
)
)
)
)
)
独角戏
这个程序是楼上的反向选择，冻结所选实体所在图层以外的全部图层(defun c:FreezeOther()
(setqDIMENSION (entget (car (entsel "Please choose an object:" ))))
(setq TEXT (cdr (assoc '8 DIMENSION)))
(setvar "clayer" TEXT)
(setq Cname (getvar "clayer"))
(command "layer" "F" TEXT "")
(setq templist (tblnext "LAYER" T))
(while templist
(setq name (cdr (assoc 2 templist)))
(if(/= name TEXT) (command "layer" "F" name ""))
(setq templist (tblnext "LAYER"))
)
)
独角戏
解冻全部图层(defun c:unFreezeAll()
(setq templist (tblnext "LAYER" T))
(while templist
(setq name (cdr (assoc 2 templist)))
(command "layer" "T" name "")
(setq templist (tblnext "LAYER"))
)
(command "_regenall")
) 下次回复有代码的时候，勾选“禁用 Smilies”，就不会出现六楼那样的笑脸符号
我自说自话
重画剖面线：如果剖面线的边界发生变化，如拉伸后剖面线没有与边界同步调整，下面的程序可以“修复剖面线”。只对简单的图形有效（《=3 个分开的图形）。当然图形得是封闭的，原来的剖面线位置变化不大。(defun C:hath()
(setqDIMENSION(car (entsel)))
(setq SSL NIL)
(setq ssL (ssadd))
(ssadd DIMENSION SSL)
(setqDIMENSION (entget DIMENSION))
(setq no (cdr (assoc '98 DIMENSION)))
(if (<= no 3)
(progn
(if (= no 1)
(progn
(setq l1 (length DIMENSION))
(setq p1 (cdr (nth (- l1 1) DIMENSION)))
(command "-bhatch" p1 "")
(command "_erase" SSL "")
))
(if (= no 2)
(progn
(setq l1 (length DIMENSION))
(setq p1 (cdr (nth (- l1 1) DIMENSION)))
(setq p2 (cdr (nth (- l1 2) DIMENSION)))
(command "-bhatch" p1 p2 "")
(command "_erase" SSL "")
))
(if (= no 3)
(progn
(setq l1 (length DIMENSION))
(setq p1 (cdr (nth (- l1 1) DIMENSION)))
(setq p2 (cdr (nth (- l1 2) DIMENSION)))
(setq p3 (cdr (nth (- l1 3) DIMENSION)))
(command "-bhatch" p1 p2 p3 "")
(command "_erase" SSL "")
))
))
(if (> no 3)(prompt "请选择简单图形！"))
)
更正
楼上的程序“修复”的剖面线没有继承原来的属性。更正以下，没有继承图层属性。也没有必要。
(defun C:hath()
(setqDIMENSION(car (entsel)))
(setq SSL NIL)
(setq ssL (ssadd))
(ssadd DIMENSION SSL)
(setqDIMENSION (entget DIMENSION))
(setq no (cdr (assoc '98 DIMENSION)))
(setq name (cdr (assoc '2 DIMENSION)))
(setq Scale (cdr (assoc '41 DIMENSION)))
(setq angle (cdr (assoc '52 DIMENSION)))
(setq angle (angtosangle 0 0))
(if (<= no 3)
(progn
(if (= no 1)
(progn
(setq l1 (length DIMENSION))
(setq p1 (cdr (nth (- l1 1) DIMENSION)))
(command "-bhatch" "P"name Scale angle p1"")
(command "_erase" SSL "")
))
(if (= no 2)
(progn
(setq l1 (length DIMENSION))
(setq p1 (cdr (nth (- l1 1) DIMENSION)))
(setq p2 (cdr (nth (- l1 2) DIMENSION)))
(command "-bhatch" "P"name Scale angle p1 p2 "")
(command "_erase" SSL "")
))
(if (= no 3)
(progn
(setq l1 (length DIMENSION))
(setq p1 (cdr (nth (- l1 1) DIMENSION)))
(setq p2 (cdr (nth (- l1 2) DIMENSION)))
(setq p3 (cdr (nth (- l1 3) DIMENSION)))
(command "-bhatch" "P"name Scale angle p1 p2 p3 "")
(command "_erase" SSL "")
))
))
(if (> no 3)(prompt "请选择简单图形！"))
)
我自说自话
习惯上CAD画图要分若干个图层，例如："1文字"、"2标注"、"3剖面"等，下面的程序可以把不同分类的实体分别放到各自的图层中，“各就各位！”(defun c:movelayer ()
(setq layname "1文字")
(setq ssl (ssget "X" (list (cons 0 "MTEXT"))))
(if (/= ssl nil) (command "ChPROP" ssl "" "layer" layname""))
(setq ssl (ssget "X" (list (cons 0 "TEXT"))))
(if (/= ssl nil) (command "ChPROP" ssl "" "layer" layname""))
(setq layname "2标注")
(setq ssl (ssget "X" (list (cons 0 "LEADER"))))
(if (/= ssl nil) (command "ChPROP" ssl "" "layer" layname""))
(setq ssl (ssget "X" (list (cons 0 "DIMENSION"))))
(if (/= ssl nil) (command "ChPROP" ssl "" "layer" layname""))
(setq layname "3剖面")
(setq ssl (ssget "X" (list (cons 0 "HATCH"))))
(if (/= ssl nil) (command "ChPROP" ssl "" "layer" layname""))
) 下面的程序可以根据选择的对象显示不同的对话框。
前提是确定已经加载了ddchprop.LSP和ddmodify.LSP
(load "C:\\Program Files\\AutoCAD R14\\SUPPORT\\ddchprop")
(load "C:\\Program Files\\AutoCAD R14\\SUPPORT\\ddmodify")
(defun C:ai_propchk()
(setq SSL (SSGET))
(IF (= (sslength ssL) 1)
(progn
(setqDIMENSION (entget (ssname ssL 0)))
(setq TEXT (cdr (assoc '0 DIMENSION)))
(setq set 0)
(if (= TEXT"TEXT") (progn (COMMAND "_ddedit" SSL "") (setq set 1)))
(if (= TEXT"MTEXT") (progn (COMMAND "_ddedit" SSL "") (setq set 1)))
(if (= TEXT"DIMENSION") (progn (COMMAND "_ddedit" SSL "") (setq set 1)))
(if (= TEXT"HATCH") (progn (COMMAND "_hatchedit" SSL) (setq set 1)))
(if (= TEXT"INSERT") (progn (COMMAND "_ddatte" SSL) (setq set 1)))
(if (= set 0) (ddmodify (ssname ssL 0)))
)
)
(IF (> (sslength ssL) 1) (ddchprop ssl))
) 图纸中标注的尺寸，有的是标注值与实际值不等，这样的尺寸有时会带来麻烦，下面的程序可以把
标注值与实际值不等的尺寸指出来，用“150号颜色”显示它。
(defun C:CHDIM()
(setq ssl (ssget "X" (list (cons 0 "DIMENSION"))))
(setq N (- (sslength ssl) 1))
(setq test 0)
(while (<= testN )
(setq DIMENSION (ENTGET (ssname ssl test)))
(setq Dimval (cdr (assoc '1 DIMENSION)))
(if (/= Dimval "")
(progn
(setq len (strlen Dimval))
(setq test2 1)
(setq key 0)
(while (<= test2(- len 1))
(if (= (substr Dimval test2 2) "<>")(setq key 1))
(setq test2 (+ 1 test2))
)
(if (= key 1)
(progn
(setq SS NIL)
(setq ss (ssadd))
(setq DIMENSION (ssname ssl test))
(ssadd DIMENSION SS)
(command "change" ss "" "p" "c" "150" "")
)
)
)
)
(setq test (+ 1 test))
)
)
页:
[1]
2