请高手帮修改一个程序

zedcar

　　　在网上找的一个删除重复图元的ＬＩＳＰ程序　加载使用后发现对重复线段的删除有时候无效　而且线段内部的线段无法删除　就是说如果一条线段长１００一条长５０　使用这个删除不掉！！请高手帮忙修改下！！
　以下是程序原文：（附件内容是程序源文件）
(defun c:ere()
8 l( t+ K# w6 H$ n' U  (setq m0 (getpoint "\n左下角："))
. \9 H; m6 U  L6 q  (setq m1 (getpoint "\n右上角："))
% |7 U) F* N; m1 j  (setq x0 (car m0) x1 (car m1) y0 (cadr m0) y1 (cadr m1) m2 m0 x2 x0 y2 y0)
  (while (< x2 x1)
9 ]2 M- J" z/ ?5 p% x$ T9 Z    (setq y2 y0 m3 m2)
% q+ ]# M0 R% S( G" E    (while (< y2 y1)
& S: J5 A8 _: m      (setq m4 (polar m3 0.785398 70.72))
; T# Z( c3 m8 P4 A( w      (setq a (ssget "_C" m3 m4))
& E& l6 p& p7 @. e0 P      (if (not a)(setq i 0)(setq i (sslength a)))
      (while (> i 1)
        (setq j (- i 1))
  L, Z3 a. H8 h9 a8 I1 ^; P6 L4 V$ e  x        (setq b (ssname a (setq i (1- i)))) ;(setq b (ssname a 1))
        (setq c (entget b))
+ ~4 h0 i9 U; }1 @* J, {& I        (setq d (cdr (assoc 0 c)))
        (while (> j 0)
          (setq b1 (ssname a (setq j (1- j))))
5 A) Z$ I) [# t( R6 B; T          (setq c1 (entget b1))
9 i0 S: q, V. B  P. o* ^; H          (setq d1 (cdr (assoc 0 c1)))
$ C& n( `1 t$ ^* Y! G8 d/ Y          (if (= d d1)
            (if (= d "LINE")
6 |; o% [: m1 |+ v# t6 b. m              (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
# d8 l+ P' W9 K  O+ Q' P                       (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
. f# c+ Y+ p1 z! h                       (= (rtos (cadr (assoc 11 c)) 2 4)(rtos (cadr (assoc 11 c1)) 2 4))
                       (= (rtos (caddr (assoc 11 c)) 2 4)(rtos (caddr (assoc 11 c1)) 2 4))
, v8 Y1 @- }, i8 ^' g7 ?. h' a                  )(command "erase" b1 "")
              )
              (if (= d "INSERT")
8 }  t/ ~6 Y3 d+ r                (if (and (equal (assoc 2 c) (assoc 2 c1))
8 @( Y2 c8 L0 d  R; _1 o                         (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
4 [$ N: k8 D+ D& Z7 |# H: J                         (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                    )(command "erase" b1 "")
7 T- O6 _6 b. o+ ^! b                )
                (if (= d "LWPOLYLINE")
8 s4 I; Y* }2 B4 }                  (progn
+ h* n) C* X( Q% g) w                    (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
                    (while (and e e1)
                      (progn
                      (setq f (car e) f1 (car e1) e (cdr e) e1 (cdr e1))
                      (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)))
! w; Q+ P$ V: w1 S% b3 a2 p$ `4 D                      (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)
                        (if (not e1) (command "erase" b1 "")(if (not e)
3 u: f! M& M  B: A* S) j                           (progn (command "erase" b "")(setq b b1 b1 nil))))
/ L. F) m9 y' L0 t                  ) ) ) )         
& h& Z  s. _3 T+ v: N                  (if (= d "SPLINE")
) B& E& E% z4 J3 |                    (progn
                      (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
                      (while (and e e1)
4 l+ r2 y" T& ~8 U! m                        (progn
- j; I) U3 \" z, A. N( s8 k                          (setq f (car e) f1 (car e1) e (cdr e) e1 (cdr e1))
9 Q' H' U# Y5 \7 {# u; {                          (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)))
* h3 R9 s, |/ v  z( b- w                          (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)
7 ^: A. Q8 O  z- y5 @. u7 D                            (if (not e1 ) (command "erase" b1 "")(if (not e)(progn (command "erase" b "")(setq b b1 b1 nil))))
, X5 ^! @1 y4 l, M; I                    ) ) ) )         
                    (if (= d "TEXT")
                      (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
4 z/ V' {0 N3 X5 s7 ^# p7 g                               (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
! v/ M8 L" N" c" k2 d& j                          )(command "erase" b1 "")
                      )
" B0 M2 z- e6 z  [  r/ d9 t) q                      (if (= d "CIRCLE")
) _$ G7 S  ]! f  a3 }  T, S                        (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
) f9 o6 `3 R( ^0 s* O: @                                 (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
# w& J& T5 ]* `+ R3 W                                 (= (rtos (cdr (assoc 40 c)) 2 4)(rtos (cdr (assoc 40 c1)) 2 4))
2 n  Y( H: r- ?2 r  H                            )(command "erase" b1 "")
) H: ~: u/ G( ]! }; t      ) ) ) ) ) ) ) ) ) )
9 e9 @" z$ r" C9 ~* [* h( X4 f      (setq m3 (polar m3 1.5708 50.0) y2 (+ y2 50.0))
0 w, |8 G  ]! ?3 ]; u5 J8 c    )
1 h/ d$ F( Z0 _& C. L    (setq m2 (polar m2 0.0 50.0) x2 (+ x2 50.0))
  )
  (princ)
)
(princ "\n\"ere\"启动")
% q0 S, c9 T2 L1 [- ^
8 ?* T& l6 V; Y[ 本帖最后由 zedcar 于 2008-11-26 09:35 编辑 ]

maoyangmy

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

zedcar

原帖由 maoyangmy 于 2008-11-26 11:05 发表 http://www.3dportal.cn/discuz/images/common/back.gif
/ x! @5 w# |4 _# c1 X0 b8 n" e7 W# y( O有没有中间使用变量得说明？做什么用得？

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

ljm68

给你一个思路：
' j; a! O1 L; x7 k, n8 |  t    处理"LINE"时，增加一个判定函数，用于首先判定直线L1的两个端点是否在直线L2上面；若在，再判定直线L1的两个端点是否在直线L2的两个端点以内，则返回直线L1，否则返回直线L2。
    判定直线L1的两个端点是否在直线L2上面：
& H: S; ^, ~3 A4 [8 o/ h, `       可以逐点计算直线L1的两个端点到直线L2的距离是否小余你的精度要求，若小余，则判定为该点在直线L2上，否则，该点不在直线L2上。

SunVei

1.    
   
2.     (defun dxg (code ele)
   
3.       (cdr (assoc code (entget ele)))
   
4.     )
     {# ]1 V) K# j. e( L
5.       
   
6. 
   2 `6 O5 \' E; F( ~
7.     (defun vpt (a b c)
   & z  I1 R+ P9 ?9 Z
8.        (equal
   
9.          (if (caddr a) a (reverse (cons 0.0 (reverse a))))
   * G1 l* X. y3 O4 j7 v; q
10.          (if (caddr b) b (reverse (cons 0.0 (reverse b))))
    
11.          (expt 0.1 c)
    
12.        )
    
13.     )
    4 W) z* a2 [4 w* G" f$ B
14.    
    : S9 P( q$ |9 ], t2 B
15. ;;; =========== for Test only =========================================
    
16. ;;; 删除线段内的短线
    
17. ;; ssen = Line Selection
    
18. (setq nn (sslength ssen))
    2 @3 B: {" W' X4 c
19. (cond
    9 {6 j: ]; H) S* U- w- v
20.   ((< nn 2) nil)                        ; Nothing to do
    , G8 l: A: W+ b9 x  l
21.   (T
    8 M7 W, [/ z1 T8 ?/ v- ^6 M* v$ L
22.    (princ "\nProceeding with Line ....."
    8 C) N0 ?1 k" D/ q2 y+ _
23.    (while (setq ee (ssname ssen (setq nn (1- nn))))
    5 x( ~3 j( V7 m, D- T
24.      (cond
    
25.        ((null (entget ee)))                ; bypass
    
26.        (T
    
27.         (setq p1  (dxg 10 ee)
    
28.               p2  (dxg 11 ee)
    
29.               v1  (angle p1 p2)
    / p$ N. G3 C5 w4 Y, V
30.               e1d (cdddr (cddr (entget ee)))
    + E' ^/ }, X- ?9 |/ \% [: v
31.               sc  (ssget "f" (list p1 p2) '((0 . "LINE")
    
32.               sum (if sc (sslength sc))
    
33.         )
    / w/ U- n. u1 ]- a! ?- m
34.         (while (and (entget ee) (> sum 0))
    
35.           (setq e1 (ssname sc (setq sum (1- sum))))
    $ |2 @/ N) Y- c5 `8 N
36.           (cond
    
37.             ((eq e1 ee) nil)                ; Itself
    
38.             ((equal (cdddr (cdddr (entget e1))) e1d)
    ( c# }" B  i; P3 ^
39.              (entdel e1)
    : t& O' o, E1 [0 y) f5 D
40.             )
    & a/ A( @% D  t2 _! H. v: \8 a6 a5 [
41.             (T
    
42.              (setq p3 (dxg 10 e1)
    
43.                    p4 (dxg 11 e1)
    / Y6 N* W( b% u
44.                    v2 (if (vpt p1 p3 5)
    
45.                         (angle p2 p3)
    . Z0 y( }* g+ f) `9 Y8 ?- b
46.                         (angle p1 p3)
    
47.                       )
    ; a9 l+ j* N2 Q1 T: h% ^
48.              )
    ! A% Q) |3 e+ T
49.              (if (< (rem (abs (- v1 v2)) pi) 0.0001)
    8 D) T6 n' h6 e/ t2 z, }
50.                (if (< (distance p3 p4) (distance p1 p2))
    1 w2 Y4 X: ~- L, a6 G% a+ n- B
51.                  (entdel e1)
    & ^3 U, O' ?$ i, L  D
52.                  (entdel ee)
    . {! b4 ?; l8 u, c4 F3 S& L, m: \
53.                )
    8 w$ M* {) [: j
54.              )
    
55.             )
    
56.           )
    * P5 Q4 g6 x1 @( j, e8 b3 s
57.         )
    
58.        )
    . r6 ~5 M) |( W0 P1 I
59.      )
    
60.    )
    # ?. C1 m8 S* e+ B2 \4 S" ]
61.   )
    1 T& W/ c2 a8 _: `  H
62. )
    
63. 
    9 R+ p0 r- |1 c2 C/ Z. e( b$ E8 Z

复制代码

[ 本帖最后由 SunVei 于 2008-12-6 23:24 编辑 ]

cai813

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