jaminth
发表于 2007-3-18 12:31:00
9楼的程序好乱,能不能整理一下!拷下来,不知道怎么用!!
MRHDF
发表于 2007-8-9 16:37:00
<p>这个程序我拷贝下来就是一行 ，看得都晕。你有lisp文件么？/共享下好么</p>
MRHDF
发表于 2007-8-9 16:39:00
9楼的程序有整理出来的 lisp么。我那别人的图纸继续画，郁闷死了 都是重线断线在里面，几度崩溃。。。
天龙八部
发表于 2007-8-14 16:38:00
<p>这也要编程啊！ET里有OV清理重线的工具啊！重线不过是判断所选择的实体对象是否大于一而已，即使编程也很简单</p><p>public sub dfsdsfsdf()</p><p>dim fssfsdfsdfsd as acadentity</p><p>dim pppsdffsf as variant</p><p>thisdrawing.utility.getentity fssfsdfsdfsd,pppsdfffsf,"select 选择OBJECT"</p><p>IF typeof fssfsdfsdfsd is "line" then '也可以是ARC </p><p>if fssfsdfsdfsd.count>1 then</p><p>fssfsdfsdfsd.delete</p><p>end if </p><p>end if</p><p></p><p></p><p></p><p></p><p>end sub</p><p></p>
liuhoujun
发表于 2008-4-1 09:15:00
看不懂能不能编好贴上来!俺是菜鸟!
AMTONNY
发表于 2008-4-26 20:34:00
试一下我这个，AP加载后输命令DUP，是别人程序里的
jj2098
发表于 2008-5-13 10:51:00
<p>前生所提供的程序，很好用，我已测试过了。不过程序没有分行，在使用前需要编辑一下。下面是我编辑的，贴出来供参考。</p><p>;;;標題: 【解決方案】消除重線的LISP程序，使用純LISP函数，<br/>;;;適用于任何AUTOCAD平台。不考慮圖層，只要是重線就處理。<br/>;;;________________________________________________________<br/>(DEFUN ww ()<br/> (SETQ ls (ENTSEL "\n 請選取一條直線:..."))<br/> (SETQ ls (CAR ls))<br/> (SETQ p1 (TRANS (CDR (ASSOC 10 (ENTGET ls))) 0 1)<br/> p2 (TRANS (CDR (ASSOC 11 (ENTGET ls))) 0 1)<br/> )<br/> (SETQ ls (ANGLE p1 p2)<br/> ls1 (+ ls (* PI 1.5))<br/> )<br/> (SETQ p0 (GETPOINT "\n 請輸入一個點!.."))<br/> (SETQ p0 (TRANS p0 1 0))<br/> (SETQ pe (POLAR p0 ls1 1))<br/> (SETQ pp (INTERS p1 p2 p0 pe nil))<br/> (SETQ #l (DISTANCE pp p0))<br/> (PRINC "\n 距離為:")<br/> (PRINC #l)<br/>)<br/>;;;________________________________________________________<br/>;;;内容:<br/>;;;清重 LINE<br/>;;;消除重線，不生成任何新的LINE<br/>;;;程序沒考慮圖層，只要是重線，就處理<br/>;;;内有詳細的注釋，?助朋友理解開發思路。<br/>;;;這個程序很複雜，用了很多技巧。希望能對朋友有?助<br/>;;;命令：c:rdup (setvar "cmdecho" 0)<br/>;;;子程序 (ran), 將LISP表按關鍵字排序。參數 'a' 為要排序的LISP表。<br/>;;;例如執行程序: (ran '((3 3.2) (5.4 4.8) (3 3) (-0.4 5.5) (3 3)))<br/>;;;該程序將返回: ((-0.4 5.5) (3 3) (3 3.2) (5.4 4.8))<br/>(DEFUN ran (a / b c d mn mx)<br/> (SETQ c (MAPCAR 'CAR a)<br/> mn (APPLY 'MIN c)<br/> mn (1- mn)<br/> )<br/> (WHILE (< mn (SETQ mx (APPLY 'MAX c)))<br/> (SETQ c (SUBST mn mx c))<br/> (WHILE (SETQ d (ASSOC mx a))<br/> (SETQ a (SUBST '(nil) d a)<br/> b (CONS d b)<br/> )<br/> )<br/> )<br/> b<br/>)<br/>;;;子程序 (rz), 消去點 'p' 的 Z-坐標。<br/>(DEFUN rz (p) (LIST (CAR p) (CADR p)))<br/>;;;子程序 (p-l1), 求點到直線距離程序的前半部分 (求常數'c1','c2'和'c3')。<br/>;;;參數 'p1' 和 'p2' 為直線的兩個端點。<br/>(DEFUN p-l1 (p1 p2 / x1 y1 x2 y2)<br/> (SETQ x1 (CAR p1)<br/> y1 (CADR p1)<br/> x2 (CAR p2)<br/> y2 (CADR p2)<br/> c1 (- y2 y1)<br/> c2 (- x1 x2)<br/> c3 (SQRT (+ (* c1 c1) (* c2 c2)))<br/> c1 (/ c1 c3)<br/> c2 (/ c2 c3)<br/> c3 (/ (- (* x2 y1) (* x1 y2)) c3)<br/> )<br/>)<br/>;;;子程序 (p-l2), 求點到直線距離程序的後半部分 (返回距離?)。<br/>;;;參數 'p0' 為點坐標。<br/>(DEFUN p-l2 (p0) (+ (* c1 (CAR p0)) (* c2 (CADR p0)) c3))<br/>;;;子程序 (rddo1), 合並一條直線上的各線段。<br/>(DEFUN rddo1 (l2 / e el c1 c2 c3 ln1 ll1 ll2 ll3 ll4 lle len len1 p z)<br/> (SETQ ll (CAR l2)<br/> p1 (CAR ll)<br/> p2 (CADR ll)<br/> a1 (ANGLE p1 p2)<br/> p3 (POLAR p1 (+ pi2 a1) mx)<br/> n (+ n (LENGTH l2))<br/> )<br/>;;;分別求出直線上某點到各線段上兩個端點的距離, 並與實體名一同存入表 'll1'。<br/>;;;表 'll1' 的格式為 ((距離1 實體名1) (距離2 實體名2) . . .)。<br/>;;;'lle' 為各線段的實體名表, 格式為 (實體名1 實體名2 . . .)<br/> (p-l1 p1 p3)<br/> (FOREACH ll l2<br/> (SETQ e (LAST ll)<br/> ll1 (CONS (LIST (p-l2 (CAR ll)) e) ll1)<br/> ll1 (CONS (LIST (p-l2 (CADR ll)) e) ll1)<br/> lle (CONS e lle)<br/> )<br/> )<br/>;;;'ll2' 為臨時實體名表, 格式為 (實體名1 實體名2 . . .)。<br/>;;;'ll4' 為合並完成後的線段表, 格式為 ((首端1 . 末端1) (首端2 . 末端2) . . .)。<br/> (SETQ ll1 (ran ll1)<br/> ln1 (+ mx (CAAR ll1))<br/> ll4 nil<br/> )<br/> (FOREACH ll ll1<br/> (SETQ ln (CAR ll)<br/> e (CADR ll)<br/> )<br/> (IF ll2<br/> (PROGN<br/>;;;此時有重疊的線段。<br/> (SETQ ll3 (MEMBER e ll2)<br/> ll2 (IF ll3<br/> (APPEND (CDR ll3) (CDR (MEMBER e (REVERSE ll2))))<br/>;;;結束一條重線。<br/> (CONS e ll2) ;將新重線的實體名加入 'll2'。<br/> )<br/> )<br/> (IF (NOT ll2)<br/>;;;結束一條線的合並, 將其存入 'll4'。<br/> (SETQ ll4 (CONS (CONS (POLAR p1 a1 ln) p2) ll4)<br/> ln1 ln<br/> )<br/> )<br/> )<br/> (PROGN<br/>;;;此時沒有重疊的線段。<br/> (IF (EQUAL ln1 ln mm)<br/> (SETQ ll4 (CDR ll4)) ;消去前一條線, 使首尾相接的兩條線連續。<br/> (SETQ p2 (POLAR p1 a1 ln)) ;求出一條新線的起始點。<br/> )<br/> (SETQ ll2 (CDR ll)) ;將起點實體名加入 'll2'。<br/> )<br/> )<br/> )<br/> (IF (> (SETQ len (LENGTH ll4)<br/> len1 (LENGTH lle)<br/> )<br/> len<br/> )<br/> (PROGN (REPEAT (- len1 len)<br/> (SETQ e (CAR lle)<br/> lle (CDR lle)<br/> )<br/> (ENTDEL e)<br/> )<br/>;;;用表 'll4' 中的線段更新表 'lle' 中的線段。<br/> (FOREACH ll ll4<br/> (SETQ e (CAR lle)<br/> lle (CDR lle)<br/> el (ENTGET e)<br/> p (ASSOC 10 el)<br/> z (CDDDR p)<br/> el (SUBST (CONS 10 (APPEND (CAR ll) z)) p el)<br/> el (SUBST (CONS 11 (APPEND (CDR ll) z)) (ASSOC 11 el) el)<br/> )<br/> (ENTMOD el)<br/> )<br/> )<br/> )<br/> (SETQ n (- n len))<br/>;;;?畫 40 根線, 在提示行更新一次報數。<br/> (IF (> (- n n2) 40)<br/> (PROGN (SETQ n2 n) (PRINC (STRCAT st2 (ITOA n))))<br/> )<br/>)<br/>;;;子程序 (rddo), 對一組同角度的線段進行重線合並。<br/>;;;參數 'l0' 為線段表, 其格式為<br/>;;; ((首端1 末端1 實體名1) (首端2 末端2 實體名2) . . .)。<br/>(DEFUN rddo (l0 / e1 a1 p1 p2 p3 c1 c2 c3 ln l1 l2 ll ll1)<br/> (SETQ ll (CAR l0)<br/> p1 (CAR ll)<br/> p2 (CADR ll)<br/> l1 (LIST (LIST 0. ll))<br/> )<br/>;;;將 'l0' 中各項, 按距離進行分類存入表 'l1'<br/>;;;'l1' 的格式為 ((距離1 (首端1 末端1 實體名1)<br/>;;; (首端2 末端2 實體名2) . . .) . . .)<br/> (p-l1 p1 p2)<br/> (FOREACH ll (CDR l0)<br/>;;;變量 'ln' 為該線段與首根直線的距離。<br/> (SETQ ln (p-l2 (CAR ll))<br/> l2 l1<br/> )<br/> (WHILE (AND (SETQ ll1 (CAR l2)) (NOT (EQUAL ln (CAR ll1) mm)))<br/> (SETQ l2 (CDR l2))<br/> )<br/>;;;將距離?近似的線段歸入同一個子表?, 否則?開一個新的子表。<br/> (SETQ l1 (IF ll1<br/> (SUBST (APPEND ll1 (LIST ll)) ll1 l1)<br/> (CONS (LIST ln ll) l1)<br/> )<br/> )<br/> )<br/>;;;對表 'l1' 中各組同距離 (即在一條直線上) 的線段進行重線合並。<br/> (FOREACH l2 l1<br/> (SETQ l2 (CDR l2))<br/> (IF (CDR l2)<br/> (rddo1 l2)<br/> ) ;一組線多于一根才進行處理。<br/> )<br/>)<br/>;;;主程序 (c:rdup), 合並或去除重線 (處理圖?全部 LINE 實體)。<br/>(DEFUN c:rdup (/ osm mm mx pi2 st1 st2 ss1 e1 el1 n n1 n2 a1 p1 p2 l1 ll<br/> ll1)<br/> (GC)<br/> (PROMPT "\n選取要處理的LINE<全選>:")<br/> (IF (NOT (SETQ ss1 (SSGET '((0 . "LINE")))))<br/> (SETQ ss1 (SSGET "x" '((0 . "LINE"))))<br/> )<br/>;;;變量 'mm' 為距離微量 (在該距離?的線段均視為重合)。<br/> (COMMAND "undo" "be")<br/> (SETQ osm (GETVAR "osmode")<br/> mx (GETVAR "viewsize")<br/> mm (* 3e-4 mx)<br/> pi2 (/ PI 2)<br/> st1 "\r搜索到直線數： "<br/> st2 "\r已經去除重線數： "<br/> n 0<br/> n1 0<br/> n2 0<br/> )<br/> (SETVAR "osmode" 0)<br/> (SETVAR "highlight" 0)<br/> (PRINC "\n")<br/>;;;對全體 LINE 實體, 按角度進行分類存入表 'l1'。<br/>;;;'l1' 的格式為 ((角度1 (首端1 末端1 實體名1)<br/>;;; (首端2 末端2 實體名2) . . .) . . .)。<br/> (WHILE (SETQ e1 (SSNAME ss1 n))<br/> (SETQ n (1+ n)<br/> el1 (ENTGET e1)<br/> p1 (rz (CDR (ASSOC 10 el1)))<br/> p2 (rz (CDR (ASSOC 11 el1)))<br/> )<br/> (IF (EQUAL p1 p2 mm)<br/> (PROGN<br/>;;;線段長度小于 'mm', 認為是超短線, 做擦除處理。<br/> (ENTDEL e1)<br/> (SETQ n1 (1+ n1))<br/> )<br/>;;;將角度?近似的線段歸入同一個子表?, 否則?開一個新的子表。<br/> (SETQ ll1 (LIST (LIST p1 p2 e1))<br/> a1 (ANGLE p1 p2)<br/> a1 (RTOS (IF (< a1 PI)<br/> a1<br/> (- a1 PI)<br/> )<br/> 2<br/> 3<br/> )<br/> ll (ASSOC a1 l1)<br/> l1 (IF ll<br/> (SUBST (APPEND ll ll1) ll l1)<br/> (CONS (CONS a1 ll1) l1)<br/> )<br/> )<br/> )<br/>;;;?處理 128 根線, 在提示行更新一次報數。<br/> (IF (= 127 (LOGAND 127 n))<br/> (PRINC (STRCAT st1 (ITOA n)))<br/> )<br/> )<br/> (PRINC (STRCAT st1<br/> (ITOA n)<br/> (IF (ZEROP n1)<br/> ""<br/> (STRCAT ". 刪除超短線 " (ITOA n1))<br/> )<br/> ".\n"<br/> )<br/> )<br/> (SETQ n1 (- n n1)<br/> n 0<br/> )<br/>;;;對表 'l1' 中各組同角度的線段進行重線合並。<br/> (FOREACH ll l1<br/> (SETQ ll (CDR ll))<br/> (IF (CDR ll)<br/> (rddo ll)<br/> )<br/>;;;一組線多于一根才進行處理。<br/> )<br/> (PRINC<br/> (STRCAT st2 (ITOA n) ". 還剩 " (ITOA (- n1 n)) " 條線.")<br/> )<br/> (REDRAW)<br/> (COMMAND "undo" "e")<br/> (SETVAR "osmode" osm)<br/> (SETVAR "highlight" 1)<br/> (PRINC)<br/>)</p>
claotlaot
发表于 2008-6-29 18:27:00
<p>非常实用的程序，收藏了，谢谢</p>
CAD83
发表于 2008-7-5 11:50:00
<p>直线就行，对圆弧没用，，，，</p>
FANGZHENG158
发表于 2008-7-8 12:59:00
对重复的字没有用