[求助]高手请进有关于程序问题?
<p>为何本程序"butt.LSP"墙线丁字剪,无法剪除"butt.GIF"图中之A处线段,麻烦高手</p><p>检视原因何在,谢谢!</p><p>(defun c:butt() <br/>(princ "\nClean up T intersection ... ") <br/>(setq a nil temp nil temp1 0 ptlist '()dist nil dist1 nil pa1 nil pa2 nil) <br/>(princ "\nCross wall lines to extend or trim: ") <br/>(command "select" "auto" pause) <br/>(setq lgroup(ssget "p")) <br/>(setq point1(cdr(assoc 10(entget(ssname lgroup 0))))point2(cdr(assoc 11(entget(ssname lgroup 0))))) <br/>(princ "\nCross wall lines to Butt to: ") <br/>(command "select" "auto" pause) <br/>(setq bgroup(ssget "p")) <br/>;;;(pre) ;;;*** <br/>(setq scalem 1) ;;;*** <br/>(if(null maxwal) <br/> (progn(setq maxwal(* scalem 12))(setq temp(getdist(strcat "\nMaximum wall thickness = <"(rtos maxwal)">: "))) <br/> (if temp(setq maxwal temp)))) <br/> (while(< temp1(sslength bgroup)) <br/> (setq ent(ssname bgroup temp1)) <br/> (if(=(cdr(assoc 0(entget ent)))"LINE") <br/> (progn <br/> (setq a1(cdr(assoc 10(entget ent)))a2(cdr(assoc 11(entget ent)))) <br/> (setq p1(inters(list(car point1)(cadr point1))(list(car point2)(cadr point2))(list(car a1)(cadr a1))(list(car a2)(cadr a2))nil)) <br/> (setq p1(list(car p1)(cadr p1)(caddr a1))) <br/> (if(<(distance point1 p1)(distance point2 p1)) <br/> (setq dist1(distance point1 p1)) <br/> (setq dist1(distance point2 p1))) <br/> (if(null dist) <br/> (setq dist dist1)) <br/> (if(/=(inters(list(car point1)(cadr point1))(list(car point2)(cadr point2))(list(car a1)(cadr a1))(list(car a2)(cadr a2)))nil) <br/> (if(or(= dist1 0)(>= dist1 dist))(setq pa1 a1 pa2 a2 dist dist1 ent1 ent)) <br/> (if(<= dist1 dist) <br/> (setq pa1 a1 pa2 a2 dist dist1 ent1 ent))))) <br/> (setq temp1(1+ temp1))) <br/> (setq point1 pa1 point2 pa2 temp 0) <br/> (while(< temp(sslength lgroup)) <br/> (setq doeras nil ent2(ssname lgroup temp)) <br/> (setq a1(cdr(assoc 10(entget ent2)))a2(cdr(assoc 11(entget ent2)))) <br/> (setq dist1(distance a1 a2)) <br/> (if(<= dist1 maxwal) <br/> (progn <br/> (redraw ent2 3) <br/> (setq doeras(strcase(getstring "\nErase this line <Y>: "))) <br/> (redraw ent2) <br/> (if(/= doeras "N")(command "erase" ent2 "")))) <br/> (setq temp(1+ temp))) <br/> (setq a nil temp nil temp1 0 ptlist '()) <br/> (while(< temp1(sslength lgroup)) <br/> (setq ent(ssname lgroup temp1)) <br/> (if(=(cdr(assoc 0(entget ent)))"LINE") <br/> (progn <br/> (setq a1(cdr(assoc 10(entget ent)))a2(cdr(assoc 11(entget ent)))) <br/> (setq p1(inters(list(car point1)(cadr point1))(list(car point2)(cadr point2))(list(car a1)(cadr a1))(list(car a2)(cadr a2))nil)) <br/> (setq p1(list(car p1)(cadr p1)(caddr a1))) <br/> (setq alist(entget ent)) <br/> (if(>(distance p1 a1)(distance p1 a2)) <br/> (setq alist(subst(cons 11 p1)(assoc 11 alist)alist)) <br/> (setq alist(subst(cons 10 p1)(assoc 10 alist)alist)))(entmod alist) <br/> (setq ptlist(cons p1 ptlist)))) <br/> (setq temp1(1+ temp1))) <br/> (setq distx 0 distm 1000000000000000000.0) <br/> (foreach n ptlist(setq dist1(distance n point1)) <br/> (if(> dist1 distx) <br/> (setq maxpt n distx dist1)) <br/> (if(< dist1 distm) <br/> (setq minpt n distm dist1))) <br/> (command "break" ent1 minpt maxpt) <br/> (setq lgroup nil bgroup nil p1 nil p2 nil a nil a1 nil a2 nil alist nil pa1 nil pa2 nil) <br/> (setq b nil b1 nil b2 nil blist nil lookpt nil siz nil point1 nil ent nil distm nil) <br/> (setq point2 nil point3 nil angla nil temp nil anglb nil ent1 nil distx nil) <br/>;;; (post) ;;;*** <br/> (princ)) </p> 麻烦诸位高手帮忙看此程序,谢谢! <p>麻烦大家看一下这个程序,提个问题或给个方向指引好解问题,谢谢大家!</p> 本帖最后由 作者 于 2008-10-21 12:05:20 编辑 <br /><br /> <p>不明用意,何不说说你要些什么样的功能,要达到什么样的目的.</p> <p align="left">希望程序执行结果如下附图:</p><p align="left">希望高手能帮忙完善这个程序.谢谢!</p><p align="left"></p> 确实很重要的问题,谢谢楼主分享的好程序。
页:
[1]