请高手帮修改一个程序

zedcar

　　　在网上找的一个删除重复图元的ＬＩＳＰ程序　加载使用后发现对重复线段的删除有时候无效　而且线段内部的线段无法删除　就是说如果一条线段长１００一条长５０　使用这个删除不掉！！请高手帮忙修改下！！
, r1 ~4 f% P( s7 N  g( w/ A　以下是程序原文：（附件内容是程序源文件）
(defun c:ere()
0 A( x" d3 P$ `  (setq m0 (getpoint "\n左下角："))
  (setq m1 (getpoint "\n右上角："))
! _6 a( o# L* ~  (setq x0 (car m0) x1 (car m1) y0 (cadr m0) y1 (cadr m1) m2 m0 x2 x0 y2 y0)
  (while (< x2 x1)
% D3 ^8 _1 s/ F4 j* a* [1 s    (setq y2 y0 m3 m2)
6 q0 @" \4 D. t+ F  m7 n  n    (while (< y2 y1)
/ e5 \3 v# s7 i' t- c7 c      (setq m4 (polar m3 0.785398 70.72))
      (setq a (ssget "_C" m3 m4))
0 o; h# Q0 [3 u7 R      (if (not a)(setq i 0)(setq i (sslength a)))
      (while (> i 1)
) Q( d$ @% n$ M& J% a5 G        (setq j (- i 1))
5 }% k; z! h  C" k3 j        (setq b (ssname a (setq i (1- i)))) ;(setq b (ssname a 1))
        (setq c (entget b))
, z+ C6 t! G1 Q7 s        (setq d (cdr (assoc 0 c)))
        (while (> j 0)
* D& q7 {: D. H: h1 v- z; M3 z% B          (setq b1 (ssname a (setq j (1- j))))
' L) a8 {3 Z  u  a" x1 l          (setq c1 (entget b1))
          (setq d1 (cdr (assoc 0 c1)))
; u) y- U5 o" ~; h2 [" D3 P          (if (= d d1)
            (if (= d "LINE")
8 b& d' A6 _' ^$ e% v/ A' V              (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
4 {- G4 C7 _. v& w! g/ v( K- o" V/ m                       (= (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))
/ \9 Z5 A. Q0 g4 {                       (= (rtos (caddr (assoc 11 c)) 2 4)(rtos (caddr (assoc 11 c1)) 2 4))
1 y5 n5 A; @) ], A                  )(command "erase" b1 "")
% t# S% ?1 b2 v! ]7 {9 t              )
- {7 Y6 \. D1 K+ `4 r              (if (= d "INSERT")
% G' \- x2 S2 s) }                (if (and (equal (assoc 2 c) (assoc 2 c1))
                         (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
/ n/ [1 P5 l3 \  _                         (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                    )(command "erase" b1 "")
                )
8 j2 H! Y7 ]7 m) z9 {                (if (= d "LWPOLYLINE")
& v( o3 |6 n3 n" C3 m8 b$ g! l# b                  (progn
                    (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
/ \" n$ E+ c. ^                    (while (and e e1)
) F( p. G, T9 h5 P/ M! g6 t9 `                      (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)))
4 y0 }! L. }6 j0 {- U                      (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)
) y3 ~. `- {' I: Q5 ~                        (if (not e1) (command "erase" b1 "")(if (not e)
                           (progn (command "erase" b "")(setq b b1 b1 nil))))
                  ) ) ) )         
. v4 @1 Q$ d( T/ p1 N4 n; y3 ^                  (if (= d "SPLINE")
                    (progn
                      (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)))
                          (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)
  Q9 ~6 Z& N+ V  T                            (if (not e1 ) (command "erase" b1 "")(if (not e)(progn (command "erase" b "")(setq b b1 b1 nil))))
! r( e, _/ X1 F8 ^. K' i. \                    ) ) ) )         
! l, J" W4 A3 F/ U# f& H3 R                    (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))
  G4 x# `- C5 d! ^4 d  T- @3 }                          )(command "erase" b1 "")
                      )
                      (if (= d "CIRCLE")
                        (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
4 X0 f% L; l. ~                                 (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
, N$ m6 X7 k0 D- j                                 (= (rtos (cdr (assoc 40 c)) 2 4)(rtos (cdr (assoc 40 c1)) 2 4))
                            )(command "erase" b1 "")
      ) ) ) ) ) ) ) ) ) )
( N2 M3 P2 m5 v6 F# t6 S      (setq m3 (polar m3 1.5708 50.0) y2 (+ y2 50.0))
7 d, u& f1 H4 }! a; V. Q; ]    )
    (setq m2 (polar m2 0.0 50.0) x2 (+ x2 50.0))
0 }6 L- q- m3 {* P: y' G  )
+ h) m5 n: x2 B, F2 _% H6 A  (princ)
& D( I1 I8 m$ f* Q8 ^* A" u)
(princ "\n\"ere\"启动")
  x2 {$ p- i* j/ H+ r0 q* Q
[ 本帖最后由 zedcar 于 2008-11-26 09:35 编辑 ]

maoyangmy

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

zedcar

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

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

ljm68

给你一个思路：
    处理"LINE"时，增加一个判定函数，用于首先判定直线L1的两个端点是否在直线L2上面；若在，再判定直线L1的两个端点是否在直线L2的两个端点以内，则返回直线L1，否则返回直线L2。
& W1 n$ N1 i* ]+ Y6 K1 V    判定直线L1的两个端点是否在直线L2上面：
       可以逐点计算直线L1的两个端点到直线L2的距离是否小余你的精度要求，若小余，则判定为该点在直线L2上，否则，该点不在直线L2上。

SunVei

1.    
   7 ]+ y- U3 T1 z
2.     (defun dxg (code ele)
   
3.       (cdr (assoc code (entget ele)))
   ) c( e) E7 t" K9 |
4.     )
   
5.       
   % u2 U4 D, H6 R
6. 
   3 O* [, N9 L* e7 U4 E
7.     (defun vpt (a b c)
   ! S7 x& v) h: ~/ w3 K0 s" D5 T
8.        (equal
   / a: T: y- c* H. C5 s' ?: S6 Q
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)
    ; w5 S  P( y4 e( ~
12.        )
    # z; y& e% E  s
13.     )
    
14.    
    
15. ;;; =========== for Test only =========================================
    5 }. c! c3 l3 S
16. ;;; 删除线段内的短线
    
17. ;; ssen = Line Selection
    
18. (setq nn (sslength ssen))
    
19. (cond
    
20.   ((< nn 2) nil)                        ; Nothing to do
    
21.   (T
    
22.    (princ "\nProceeding with Line ....."
    
23.    (while (setq ee (ssname ssen (setq nn (1- nn))))
    # D/ f. u" i; r% o0 K: I0 s
24.      (cond
    ' T+ ~, {; v- A; u: V
25.        ((null (entget ee)))                ; bypass
    
26.        (T
    
27.         (setq p1  (dxg 10 ee)
    
28.               p2  (dxg 11 ee)
    
29.               v1  (angle p1 p2)
    6 G2 S8 a5 L/ W0 @
30.               e1d (cdddr (cddr (entget ee)))
    
31.               sc  (ssget "f" (list p1 p2) '((0 . "LINE")
    
32.               sum (if sc (sslength sc))
    
33.         )
    4 x8 y5 ^/ Q/ j5 S8 H0 ^
34.         (while (and (entget ee) (> sum 0))
    # d: }4 W/ y# S& q3 ~
35.           (setq e1 (ssname sc (setq sum (1- sum))))
    * i# w. V1 i2 |5 E7 e% q4 N
36.           (cond
    4 u' Z  G% D6 z9 ]0 D" M- W' w
37.             ((eq e1 ee) nil)                ; Itself
    
38.             ((equal (cdddr (cdddr (entget e1))) e1d)
    
39.              (entdel e1)
    
40.             )
    
41.             (T
    ' Z! l9 K0 c. Y  l4 _
42.              (setq p3 (dxg 10 e1)
    % n, j* o* W8 I3 S% ]
43.                    p4 (dxg 11 e1)
    
44.                    v2 (if (vpt p1 p3 5)
    
45.                         (angle p2 p3)
    8 @; W1 s4 C8 h, `/ ~( M
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.                )
    9 G8 g) e5 B# W  [
54.              )
    5 s. `# f( Q& V" s' ?
55.             )
    
56.           )
    
57.         )
    & F; @8 C% I) _6 l
58.        )
    
59.      )
    # E- ^- w$ E  A
60.    )
    ( U" w, f( x/ V4 T5 ?' v! p
61.   )
    : {- I6 Q1 |& X9 U% H, L( ]  E* H
62. )
    
63. 
    

复制代码

' [8 [6 Z, \- F, g# x$ o[ 本帖最后由 SunVei 于 2008-12-6 23:24 编辑 ]

cai813

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