liu22737 发表于 2008-7-8 16:59:00

调整线形比例小程序

本帖最后由 作者 于 2008-8-13 10:40:45 编辑 <br /><br /> <p></p><p>调整线形小程序</p>

baizhan 发表于 2008-7-8 18:35:00

<p>怎么没东西的</p>

liu22737 发表于 2008-8-12 16:22:00

修改块内线型比例.lsp

本帖最后由 作者 于 2008-8-30 7:36:24 编辑 <br /><br /> <p>&nbsp;</p><p></p><p>(defun c:ssd(/ a1 lt sc pt ss ent lis_0 list_ent H&amp;D lsx_oldvars)<br/>&nbsp;(defun lsx_newerr(msg)(setq *error* lsx_olderr)(command)(command "undo" "end")(mapcar 'setvar '("cmdecho" "osmode")lsx_oldvars)(princ));endlsx_newerr<br/>&nbsp;(setq lsx_olderr *error* *error* lsx_newerr lsx_oldvars(mapcar 'getvar '("cmdecho" "osmode")))<br/>&nbsp;(setvar "osmode" 0)(setvar "cmdecho" 0)(command "undo" "group")<br/>(setq list_ent '() ss(ssadd) ent t H&amp;D nil)<br/>(prompt "\n修改块内线型比例")<br/>(command"trim")<br/>(while ent<br/>&nbsp; (command(setq ent(nentsel)pt(cadr ent)))(command pt)<br/>&nbsp; (setq list_ent(append(list(car ent))list_ent))<br/>&nbsp; (if(and(&gt;(length ent)2)(not(ssmemb(last(last ent))ss)))(setq ss(ssadd(last(last ent))ss)))<br/>&nbsp;);while<br/>(setq list_ent(vl-remove nil list_ent) lis_0 '() ent(car list_ent))<br/>(foreach ent list_ent<br/>&nbsp; (if(and(vl-position(cdr(assoc 0(entget ent)))'("LWPOLYLINE" "CIRCLE" "MLINE" "ARC" "SPLINE" "RAY" "ELLIPSE" "LINE" "XLINE"))<br/>&nbsp;&nbsp;&nbsp;&nbsp; (not(vl-position ent lis_0)))(setq lis_0(append(list ent)lis_0)));if<br/>&nbsp;);foreach<br/>(while lis_0<br/>&nbsp;&nbsp; (cond((or(= H&amp;D "H")(= H&amp;D "h"))&nbsp; (setq a1(getstring"\nHalf Scale&lt;H&gt;:"))(if(or(= a1 "D")(= a1 "d"))(setq sc 2.0 H&amp;D a1)))<br/>&nbsp;((or(= H&amp;D "D")(= H&amp;D "d"))(setq a1(getstring"\nDouble Scale&lt;D&gt;:"))(if(or(= a1 "H")(= a1 "h"))(setq sc 0.5 H&amp;D a1)))<br/>&nbsp;&nbsp;(t(setq H&amp;D(getstring"\n*&lt;H&gt;alf Scale* &amp; *&lt;D&gt;ouble Scale* &lt;H&gt;:"))<br/>&nbsp;&nbsp; (if(= "" H&amp;D)(setq H&amp;D "H"))(if(or(= H&amp;D "H")(= H&amp;D "h"))(setq sc 0.5)(setq sc 2.0))));cond<br/>&nbsp;&nbsp; (setq ent(car lis_0))<br/>&nbsp;&nbsp; (foreach ent lis_0(setq a1(entget ent))<br/>&nbsp;&nbsp;&nbsp;&nbsp; (if(setq lt(cdr(assoc 48 a1)))(entmod(subst(cons 48(* lt sc))(assoc 48 a1)a1))(entmod(append a1(list(cons 48 sc))))));foreach<br/>&nbsp;&nbsp; (command"move"ss""'(0 0)'(0 0)))while;<br/>(mapcar 'setvar '("cmdecho" "osmode")lsx_oldvars)<br/>(setq *error* lsx_olderr)<br/>(command "undo" "end")<br/>(princ)<br/>);end</p>

liu22737 发表于 2008-8-26 20:53:00

没人顶只好自己再顶下

<p>&nbsp;加强版</p><p></p><p>取消了自动安装</p>

众山小 发表于 2008-8-27 08:37:00

输入时命令名称太长了，应该简化一点

www2002 发表于 2008-8-27 09:21:00

收下试试看！！

liu22737 发表于 2008-8-27 10:43:00

送你改名源码，随你改

众山小发表于2008-8-27 8:37:00static/image/common/back.gif输入时命令名称太长了，应该简化一点

<p></p>

starlet2003 发表于 2008-8-27 12:39:00

<p>希望有源码可以研究一下</p>

display18 发表于 2010-8-28 15:18:00

<p>顶你楼主，好程序</p>

dkj0322 发表于 2010-9-9 15:55:00

谢谢分享！很不错
页: [1] 2
查看完整版本: 调整线形比例小程序