请高手帮修改一个程序

zedcar

　　　在网上找的一个删除重复图元的ＬＩＳＰ程序　加载使用后发现对重复线段的删除有时候无效　而且线段内部的线段无法删除　就是说如果一条线段长１００一条长５０　使用这个删除不掉！！请高手帮忙修改下！！
　以下是程序原文：（附件内容是程序源文件）
! N+ L; Y5 L" [* h0 U2 J7 j0 Q(defun c:ere()
3 Z7 T8 d: P3 t, s  (setq m0 (getpoint "\n左下角："))
  (setq m1 (getpoint "\n右上角："))
2 q/ K' k$ [1 o4 y4 Q  T  (setq x0 (car m0) x1 (car m1) y0 (cadr m0) y1 (cadr m1) m2 m0 x2 x0 y2 y0)
6 _0 |. \, Y) D$ E  (while (< x2 x1)
9 E: M0 C5 _5 @: H5 O& d    (setq y2 y0 m3 m2)
; c1 x; |0 S6 j# x  d    (while (< y2 y1)
& C* s. F' }2 A% w# c+ ~# C# G      (setq m4 (polar m3 0.785398 70.72))
      (setq a (ssget "_C" m3 m4))
/ ?5 S/ \! n4 X/ |      (if (not a)(setq i 0)(setq i (sslength a)))
2 t  |+ g/ G& H* [1 e      (while (> i 1)
2 f) P  l, ]2 ]( }) w/ X1 J        (setq j (- i 1))
( \6 L- L& L$ S; f2 L3 [1 ^        (setq b (ssname a (setq i (1- i)))) ;(setq b (ssname a 1))
  ^" G& A6 s, D7 X* o) W, m        (setq c (entget b))
) W. |* c, }7 O' E& m% r8 l        (setq d (cdr (assoc 0 c)))
! s4 i! h# W) M% Y$ V, R4 e        (while (> j 0)
! B! w9 Y5 R% u$ q1 g3 ]          (setq b1 (ssname a (setq j (1- j))))
9 o: T! @4 T4 ~/ z/ A          (setq c1 (entget b1))
, `2 }! j9 Q. x! y          (setq d1 (cdr (assoc 0 c1)))
$ H8 b* q9 \* c) ?: {          (if (= d d1)
; S* {' \) _0 K6 k            (if (= d "LINE")
              (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
& h- K" {  a7 v+ j                       (= (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))
                       (= (rtos (caddr (assoc 11 c)) 2 4)(rtos (caddr (assoc 11 c1)) 2 4))
                  )(command "erase" b1 "")
              )
+ _# r; w* k' b% I              (if (= d "INSERT")
" N  L$ P& i. z& e2 s/ A& x* G                (if (and (equal (assoc 2 c) (assoc 2 c1))
                         (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
- G  w. G  o) N* G" M3 A                         (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                    )(command "erase" b1 "")
" ?6 P$ Q7 y- W                )
                (if (= d "LWPOLYLINE")
) W& @( ?- ?/ |                  (progn
                    (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
# [, n) F2 S" D- u' p+ c                    (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)))
                      (if (or (/= (rtos (cadr f) 2 4)(rtos (cadr f1) 2 4))
& ~: b# O4 l- H+ }4 i                              (/= (rtos (caddr f) 2 4)(rtos (caddr f1) 2 4)))(setq e1 nil)
                        (if (not e1) (command "erase" b1 "")(if (not e)
                           (progn (command "erase" b "")(setq b b1 b1 nil))))
4 Q; y0 n8 u6 ]$ \* r+ L, |0 }                  ) ) ) )         
+ ^( N+ p7 _2 V5 T* V+ g3 u                  (if (= d "SPLINE")
                    (progn
( H6 j8 V! A$ x# d6 [. E3 T; E                      (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
  @! n$ a6 k4 d+ G7 |                      (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)))
                          (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)(progn (command "erase" b "")(setq b b1 b1 nil))))
2 s) X8 F0 _; X. M8 n& ~) m8 W                    ) ) ) )         
+ h# ?" v+ q' f+ E2 p6 W                    (if (= d "TEXT")
                      (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))
                          )(command "erase" b1 "")
                      )
2 u$ U9 X3 }; k                      (if (= d "CIRCLE")
                        (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))
9 G4 p. g/ k: p" N" i) P/ v1 z                            )(command "erase" b1 "")
  M4 S5 o) n% q/ K      ) ) ) ) ) ) ) ) ) )
      (setq m3 (polar m3 1.5708 50.0) y2 (+ y2 50.0))
    )
    (setq m2 (polar m2 0.0 50.0) x2 (+ x2 50.0))
+ l- _' h" t' w& S1 k0 g4 {  )
  (princ)
- s, ?1 F- |7 m8 Y)
(princ "\n\"ere\"启动")
" N! I) Q6 {. E% k  h( t
[ 本帖最后由 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

给你一个思路：
, H4 {$ _4 q! r, r    处理"LINE"时，增加一个判定函数，用于首先判定直线L1的两个端点是否在直线L2上面；若在，再判定直线L1的两个端点是否在直线L2的两个端点以内，则返回直线L1，否则返回直线L2。
    判定直线L1的两个端点是否在直线L2上面：
       可以逐点计算直线L1的两个端点到直线L2的距离是否小余你的精度要求，若小余，则判定为该点在直线L2上，否则，该点不在直线L2上。

SunVei

1.    
   ' B9 B1 i* B. e, z( B
2.     (defun dxg (code ele)
   
3.       (cdr (assoc code (entget ele)))
   
4.     )
   
5.       
   . F' p! N: M) q3 t7 z. J
6. 
   
7.     (defun vpt (a b c)
   & T3 {" k8 K4 `1 I7 {7 Q4 k5 H
8.        (equal
   
9.          (if (caddr a) a (reverse (cons 0.0 (reverse a))))
   
10.          (if (caddr b) b (reverse (cons 0.0 (reverse b))))
    
11.          (expt 0.1 c)
    
12.        )
    
13.     )
    
14.    
    
15. ;;; =========== for Test only =========================================
    6 Q2 d4 q6 _; E% y5 X
16. ;;; 删除线段内的短线
    # o8 `8 d  h" d: W" W
17. ;; ssen = Line Selection
    / \- D8 G2 p/ D0 F+ ]5 F
18. (setq nn (sslength ssen))
    ' W- R5 J% J6 `2 O
19. (cond
    - b( X- i0 M$ N* O
20.   ((< nn 2) nil)                        ; Nothing to do
    
21.   (T
    
22.    (princ "\nProceeding with Line ....."
    
23.    (while (setq ee (ssname ssen (setq nn (1- nn))))
    / c; K7 f* l0 j3 v) B5 ]% x3 r3 e
24.      (cond
    , x' v' u8 ~& s
25.        ((null (entget ee)))                ; bypass
    
26.        (T
    2 E8 w3 R) U4 o/ g" G
27.         (setq p1  (dxg 10 ee)
    + v  N3 l* z# _5 b5 R! K, n
28.               p2  (dxg 11 ee)
    ! A3 {2 I  W5 [
29.               v1  (angle p1 p2)
    . D6 \0 \* d2 M) w3 k, L6 u; }
30.               e1d (cdddr (cddr (entget ee)))
    
31.               sc  (ssget "f" (list p1 p2) '((0 . "LINE")
    
32.               sum (if sc (sslength sc))
    
33.         )
    - d* |9 U! E2 \! f
34.         (while (and (entget ee) (> sum 0))
    
35.           (setq e1 (ssname sc (setq sum (1- sum))))
    
36.           (cond
    + L* z- b7 p! Q% z5 b3 h9 ~
37.             ((eq e1 ee) nil)                ; Itself
    
38.             ((equal (cdddr (cdddr (entget e1))) e1d)
    6 R1 f& o# T& B7 f0 T( B) y4 c
39.              (entdel e1)
    
40.             )
    ! r, A' ]  m1 r0 ?
41.             (T
    - s$ O) w/ S( W" E" }( A0 O+ b7 m
42.              (setq p3 (dxg 10 e1)
    / a* m7 T/ B, \- O
43.                    p4 (dxg 11 e1)
    4 ~5 C+ W6 i3 H& g
44.                    v2 (if (vpt p1 p3 5)
    ) L+ O4 X6 v6 C; c# i/ q4 X7 w
45.                         (angle p2 p3)
    
46.                         (angle p1 p3)
    
47.                       )
    
48.              )
    
49.              (if (< (rem (abs (- v1 v2)) pi) 0.0001)
    
50.                (if (< (distance p3 p4) (distance p1 p2))
    
51.                  (entdel e1)
    
52.                  (entdel ee)
    
53.                )
    
54.              )
    * U, y2 M+ R0 H1 U
55.             )
    
56.           )
    8 p$ D! S6 k* Q; b8 t/ c1 [
57.         )
    ) Y5 ~6 r1 V! R1 o& ?
58.        )
    # A9 u2 C  Q& H2 E9 e
59.      )
    2 K1 i$ @& d0 D3 }% a( @
60.    )
    ; c! _6 Z/ k; I( K  ]# h) U
61.   )
    + i% H, O; ], r) s# p: P
62. )
    
63. 
    . E4 ]' G( |: S' s! {

复制代码

: |* D8 [) c3 b- k[ 本帖最后由 SunVei 于 2008-12-6 23:24 编辑 ]

cai813

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