[求助]高手请进有关于程序问题?
www.dimcax.com
[求助]高手请进有关于程序问题?
为何本程序"butt.lsp"墙线丁字剪,无法剪除"butt.gif"图中之a处线段,麻烦高手
检视原因何在,谢谢!
(defun c:butt()
(princ "\nclean up t intersection ... ")
(setq a nil temp nil temp1 0 ptlist '()dist nil dist1 nil pa1 nil pa2 nil)
(princ "\ncross wall lines to extend or trim: ")
(command "select" "auto" pause)
(setq lgroup(ssget "p"))
(setq point1(cdr(assoc 10(entget(ssname lgroup 0))))point2(cdr(assoc 11(entget(ssname lgroup 0)))))
(princ "\ncross wall lines to butt to: ")
(command "select" "auto" pause)
(setq bgroup(ssget "p"))
;;;(pre) ;;;***
(setq scalem 1) ;;;***
(if(null maxwal)
(progn(setq maxwal(* scalem 12))(setq temp(getdist(strcat "\nmaximum wall thickness = <"(rtos maxwal)">: ")))
(if temp(setq maxwal temp))))
(while(< temp1(sslength bgroup))
(setq ent(ssname bgroup temp1))
(if(=(cdr(assoc 0(entget ent)))"line")
(progn
(setq a1(cdr(assoc 10(entget ent)))a2(cdr(assoc 11(entget ent))))
(setq p1(inters(list(car point1)(cadr point1))(list(car point2)(cadr point2))(list(car a1)(cadr a1))(list(car a2)(cadr a2))nil))
(setq p1(list(car p1)(cadr p1)(caddr a1)))
(if(<(distance point1 p1)(distance point2 p1))
(setq dist1(distance point1 p1))
(setq dist1(distance point2 p1)))
(if(null dist)
(setq dist dist1))
(if(/=(inters(list(car point1)(cadr point1))(list(car point2)(cadr point2))(list(car a1)(cadr a1))(list(car a2)(cadr a2)))nil)
(if(or(= dist1 0)(>= dist1 dist))(setq pa1 a1 pa2 a2 dist dist1 ent1 ent))
(if(<= dist1 dist)
(setq pa1 a1 pa2 a2 dist dist1 ent1 ent)))))
(setq temp1(1+ temp1)))
(setq point1 pa1 point2 pa2 temp 0)
(while(< temp(sslength lgroup))
(setq doeras nil ent2(ssname lgroup temp))
(setq a1(cdr(assoc 10(entget ent2)))a2(cdr(assoc 11(entget ent2))))
(setq dist1(distance a1 a2))
(if(<= dist1 maxwal)
(progn
(redraw ent2 3)
(setq doeras(strcase(getstring "\nerase this line <y>: ")))
(redraw ent2)
(if(/= doeras "n")(command "erase" ent2 ""))))
(setq temp(1+ temp)))
(setq a nil temp nil temp1 0 ptlist '())
(while(< temp1(sslength lgroup))
(setq ent(ssname lgroup temp1))
(if(=(cdr(assoc 0(entget ent)))"line")
(progn
(setq a1(cdr(assoc 10(entget ent)))a2(cdr(assoc 11(entget ent))))
(setq p1(inters(list(car point1)(cadr point1))(list(car point2)(cadr point2))(list(car a1)(cadr a1))(list(car a2)(cadr a2))nil))
(setq p1(list(car p1)(cadr p1)(caddr a1)))
(setq alist(entget ent))
(if(>(distance p1 a1)(distance p1 a2))
(setq alist(subst(cons 11 p1)(assoc 11 alist)alist))
(setq alist(subst(cons 10 p1)(assoc 10 alist)alist)))(entmod alist)
(setq ptlist(cons p1 ptlist))))
(setq temp1(1+ temp1)))
(setq distx 0 distm 1000000000000000000.0)
(foreach n ptlist(setq dist1(distance n point1))
(if(> dist1 distx)
(setq maxpt n distx dist1))
(if(< dist1 distm)
(setq minpt n distm dist1)))
(command "break" ent1 minpt maxpt)
(setq lgroup nil bgroup nil p1 nil p2 nil a nil a1 nil a2 nil alist nil pa1 nil pa2 nil)
(setq b nil b1 nil b2 nil blist nil lookpt nil siz nil point1 nil ent nil distm nil)
(setq point2 nil point3 nil angla nil temp nil anglb nil ent1 nil distx nil)
;;; (post) ;;;***
(princ))
d
麻烦诸位高手帮忙看此程序,谢谢!
d
麻烦大家看一下这个程序,提个问题或给个方向指引好解问题,谢谢大家!
d
通过工具菜单->加载应用程序 可加载该程序，然后可直接在命令行输入相关命令运行。如需要每次启动时均加载该程序，则可以将该文件放在启动组中。
文件预览:
d
不明用意,何不说说你要些什么样的功能,要达到什么样的目的.
d
希望程序执行结果如下附图:
希望高手能帮忙完善这个程序.谢谢!