请高手帮修改一个程序

zedcar

　　　在网上找的一个删除重复图元的ＬＩＳＰ程序　加载使用后发现对重复线段的删除有时候无效　而且线段内部的线段无法删除　就是说如果一条线段长１００一条长５０　使用这个删除不掉！！请高手帮忙修改下！！
　以下是程序原文：（附件内容是程序源文件）
: |  o- x) {4 t: H" U9 d(defun c:ere()
  (setq m0 (getpoint "\n左下角："))
  (setq m1 (getpoint "\n右上角："))
1 a$ Y: w/ l+ w  (setq x0 (car m0) x1 (car m1) y0 (cadr m0) y1 (cadr m1) m2 m0 x2 x0 y2 y0)
  (while (< x2 x1)
6 L1 G* c4 ?* J    (setq y2 y0 m3 m2)
    (while (< y2 y1)
* `$ ^) Y9 n" L' k8 z& A: W      (setq m4 (polar m3 0.785398 70.72))
      (setq a (ssget "_C" m3 m4))
) N7 ?  Z. i0 l( j      (if (not a)(setq i 0)(setq i (sslength a)))
      (while (> i 1)
0 m  r  y" s. `7 {! H" \& r        (setq j (- i 1))
        (setq b (ssname a (setq i (1- i)))) ;(setq b (ssname a 1))
1 o9 O, y7 G$ h2 U3 o$ P6 m0 J        (setq c (entget b))
! ^; B) G$ Q- V6 N- D, d+ `( u0 H7 R        (setq d (cdr (assoc 0 c)))
' v$ Y8 Y* K& }  Z* Z, ]8 A8 K5 I        (while (> j 0)
          (setq b1 (ssname a (setq j (1- j))))
          (setq c1 (entget b1))
          (setq d1 (cdr (assoc 0 c1)))
  N' I3 [9 I, j0 e/ S; Q# h1 c/ [2 m) R          (if (= d d1)
            (if (= d "LINE")
% a9 R  ]  l/ B) N. Y              (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
( V( y5 h' ~% A4 x                       (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                       (= (rtos (cadr (assoc 11 c)) 2 4)(rtos (cadr (assoc 11 c1)) 2 4))
/ M& u; e) ~0 p                       (= (rtos (caddr (assoc 11 c)) 2 4)(rtos (caddr (assoc 11 c1)) 2 4))
                  )(command "erase" b1 "")
              )
              (if (= d "INSERT")
' H6 q4 W0 w. ?                (if (and (equal (assoc 2 c) (assoc 2 c1))
                         (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
                         (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                    )(command "erase" b1 "")
                )
                (if (= d "LWPOLYLINE")
                  (progn
                    (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
3 x' t9 t' |- \) i                    (while (and e e1)
0 f) W6 T  Q5 M4 d8 ], J; C                      (progn
- V! _) H# u( }: k1 a' E5 u                      (setq f (car e) f1 (car e1) e (cdr e) e1 (cdr e1))
4 O) e1 r0 a- a1 s; A  W1 }                      (while (and e (/= (car f) 10))(setq f (car e) e (cdr e)))
                      (while (and e1 (/= (car f1) 10))(setq f1 (car e1) e1 (cdr e1)))
                      (if (or (/= (rtos (cadr f) 2 4)(rtos (cadr f1) 2 4))
                              (/= (rtos (caddr f) 2 4)(rtos (caddr f1) 2 4)))(setq e1 nil)
8 a) m# Y( C8 D' F. N, g. U                        (if (not e1) (command "erase" b1 "")(if (not e)
1 B6 \4 B6 j7 k# ~                           (progn (command "erase" b "")(setq b b1 b1 nil))))
5 W) Z& D& F5 o                  ) ) ) )         
3 i' A7 L" H* i                  (if (= d "SPLINE")
9 J8 F- M! V3 u/ `( o                    (progn
- k0 o' W% W: @- Z. p4 j( N1 F" s                      (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
                      (while (and e e1)
5 _; Y+ K( Z8 s- `% D& `" e! f                        (progn
  |% L/ u0 t7 J6 r* e; ]# A- l                          (setq f (car e) f1 (car e1) e (cdr e) e1 (cdr e1))
* n( c  Z1 _* Z- A& \* v: S. X  c                          (while (and e (/= (car f) 10))(setq f (car e) e (cdr e)))
, u8 r- _& I% R2 P  T4 m! P0 r                          (while (and e1 (/= (car f1) 10))(setq f1 (car e1) e1 (cdr e1)))
                          (if (or (/= (rtos (cadr f) 2 4)(rtos (cadr f1) 2 4))(/= (rtos (caddr f) 2 4)(rtos (caddr f1) 2 4)))(setq e1 nil)
9 }3 m9 l/ @- u# c6 J                            (if (not e1 ) (command "erase" b1 "")(if (not e)(progn (command "erase" b "")(setq b b1 b1 nil))))
                    ) ) ) )         
                    (if (= d "TEXT")
                      (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
: s- h( ]  P3 T' j  r& o+ c! S                               (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
9 T  W% q& \4 H" R2 x; w                          )(command "erase" b1 "")
                      )
* _! h: N" q- ^- m$ J                      (if (= d "CIRCLE")
; m0 R/ ~! C. |& u$ `' A- V                        (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
                                 (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                                 (= (rtos (cdr (assoc 40 c)) 2 4)(rtos (cdr (assoc 40 c1)) 2 4))
7 Q+ r0 [1 l2 g4 p9 o4 R8 H+ i' g  C                            )(command "erase" b1 "")
+ ^8 F7 j8 |( X$ C      ) ) ) ) ) ) ) ) ) )
# O. k" m  R$ ^5 C      (setq m3 (polar m3 1.5708 50.0) y2 (+ y2 50.0))
- [" r* |4 F3 o    )
    (setq m2 (polar m2 0.0 50.0) x2 (+ x2 50.0))
  )
  (princ)
)
4 a7 f: |( m/ m+ r- E; @(princ "\n\"ere\"启动")
- ]3 B& g7 Z3 w/ {! a+ U9 Y3 K
[ 本帖最后由 zedcar 于 2008-11-26 09:35 编辑 ]

maoyangmy

有没有中间使用变量得说明？做什么用得？

zedcar

原帖由 maoyangmy 于 2008-11-26 11:05 发表 http://www.3dportal.cn/discuz/images/common/back.gif
有没有中间使用变量得说明？做什么用得？

没有　这个程序用来删除多余的图元。程序特点，可以删除完全重合的直线、多段线、光滑曲线（程序中设置了4位小数，当坐标数值四舍五入精确到4位小数时认为重合），删除位置重合的文字，删除位置和半径相同的圆，删除位置和块名相同的块。

ljm68

给你一个思路：
( D  z0 u5 Q8 e  ?    处理"LINE"时，增加一个判定函数，用于首先判定直线L1的两个端点是否在直线L2上面；若在，再判定直线L1的两个端点是否在直线L2的两个端点以内，则返回直线L1，否则返回直线L2。
7 r+ r4 I( \& A# Q) Y! B4 O# D    判定直线L1的两个端点是否在直线L2上面：
       可以逐点计算直线L1的两个端点到直线L2的距离是否小余你的精度要求，若小余，则判定为该点在直线L2上，否则，该点不在直线L2上。

SunVei

1.    
   
2.     (defun dxg (code ele)
   * @: E% c/ u6 x& {2 P
3.       (cdr (assoc code (entget ele)))
   " w# ]0 t2 T7 L) B) Y% t/ ]5 b1 @
4.     )
   
5.       
   0 G7 _" x- Y# W* n, E
6. 
   0 A2 x0 g# w2 E4 o; ]! H1 v# n  M
7.     (defun vpt (a b c)
   ) P1 c  m+ \5 I7 _) Q  P
8.        (equal
   ; C# P1 d8 i9 V" k! X# I  P) b' N8 x
9.          (if (caddr a) a (reverse (cons 0.0 (reverse a))))
   $ l/ U9 C; l+ _- o
10.          (if (caddr b) b (reverse (cons 0.0 (reverse b))))
    
11.          (expt 0.1 c)
    
12.        )
    
13.     )
    
14.    
    * a8 z& E! z( G4 y
15. ;;; =========== for Test only =========================================
    
16. ;;; 删除线段内的短线
    0 y/ y4 Y- x1 E2 q# V
17. ;; ssen = Line Selection
    $ E: E+ Q# h( g+ d1 h- D; A
18. (setq nn (sslength ssen))
    
19. (cond
    ) e6 D8 U! M. V5 e1 f
20.   ((< nn 2) nil)                        ; Nothing to do
    6 F' Q. M+ y) [) N: j2 R# v8 p3 u! G
21.   (T
    , @5 P) t! L! S3 F$ x; B
22.    (princ "\nProceeding with Line ....."
    , v* w. N* X" p
23.    (while (setq ee (ssname ssen (setq nn (1- nn))))
    
24.      (cond
    
25.        ((null (entget ee)))                ; bypass
    * m9 O3 h) F# s1 F  t
26.        (T
      m! g2 I+ m2 m8 N2 c, |* W5 f
27.         (setq p1  (dxg 10 ee)
    
28.               p2  (dxg 11 ee)
    
29.               v1  (angle p1 p2)
    
30.               e1d (cdddr (cddr (entget ee)))
    
31.               sc  (ssget "f" (list p1 p2) '((0 . "LINE")
    
32.               sum (if sc (sslength sc))
    
33.         )
    5 w0 b+ [( n& x& |: A; I, H' ?8 P( z
34.         (while (and (entget ee) (> sum 0))
    
35.           (setq e1 (ssname sc (setq sum (1- sum))))
    
36.           (cond
    5 y- q1 M, v& N
37.             ((eq e1 ee) nil)                ; Itself
    $ E! `1 c5 A8 H
38.             ((equal (cdddr (cdddr (entget e1))) e1d)
    
39.              (entdel e1)
    % B4 N+ ^2 R3 T$ x
40.             )
    
41.             (T
    
42.              (setq p3 (dxg 10 e1)
    
43.                    p4 (dxg 11 e1)
    
44.                    v2 (if (vpt p1 p3 5)
    8 r; A! v! [  _1 [0 Q) Z( q, ^
45.                         (angle p2 p3)
    # D( \8 o- ^7 p; a# a
46.                         (angle p1 p3)
    - H. F. G3 [3 K5 h3 O
47.                       )
    
48.              )
    , x5 x) Q, Q( j, c# q
49.              (if (< (rem (abs (- v1 v2)) pi) 0.0001)
    + z  e# l( n7 _. k. c: n9 _
50.                (if (< (distance p3 p4) (distance p1 p2))
    ( Y* Z0 m  G% u* N4 r0 Z
51.                  (entdel e1)
    
52.                  (entdel ee)
    
53.                )
      O( P6 k% P, f6 z+ R- U
54.              )
    + \- {* A3 J5 g) I# ]; H
55.             )
    8 ?9 O% M+ c% E, ]
56.           )
    0 V, l4 n# A$ Z& K, s# _' V
57.         )
    
58.        )
    5 M3 O. S: s/ _! S/ M
59.      )
    
60.    )
    & I" P( t- l8 T
61.   )
    & r  ]: B8 K$ ~3 E
62. )
    0 V- A" u- M0 D
63. 
    * T) b& g; @  i2 Y% J( H/ W; D$ ]

复制代码

  t1 t3 n  b) A' Z$ j: x. ^0 f[ 本帖最后由 SunVei 于 2008-12-6 23:24 编辑 ]

cai813

我认为对有利于促进论坛的发展,同时也激励会员多参与.但对于管理人员应该考虑工作需要,不收取流量.