请高手帮修改一个程序

zedcar

　　　在网上找的一个删除重复图元的ＬＩＳＰ程序　加载使用后发现对重复线段的删除有时候无效　而且线段内部的线段无法删除　就是说如果一条线段长１００一条长５０　使用这个删除不掉！！请高手帮忙修改下！！
　以下是程序原文：（附件内容是程序源文件）
(defun c:ere()
) Q* W0 W: r& f% u# I5 e  (setq m0 (getpoint "\n左下角："))
* D' D4 {- e% r+ y" t( N  (setq m1 (getpoint "\n右上角："))
! m$ T: v% M+ ^2 p7 |  (setq x0 (car m0) x1 (car m1) y0 (cadr m0) y1 (cadr m1) m2 m0 x2 x0 y2 y0)
1 h' q3 o- Y! v2 N7 P. T  (while (< x2 x1)
1 ~8 t! I. ^" D5 ]' D7 Y7 e. C# ?    (setq y2 y0 m3 m2)
' i) |$ n1 b. B! V: `1 H    (while (< y2 y1)
6 L& D- m& Z3 X      (setq m4 (polar m3 0.785398 70.72))
7 p' B7 s  J( @- x      (setq a (ssget "_C" m3 m4))
      (if (not a)(setq i 0)(setq i (sslength a)))
      (while (> i 1)
        (setq j (- i 1))
8 i9 j8 ^8 M9 J5 ~- m3 E/ I3 G        (setq b (ssname a (setq i (1- i)))) ;(setq b (ssname a 1))
" Y, k# H; b5 g0 m8 a: ]        (setq c (entget b))
: W6 f/ Q3 b) U+ L" k+ N        (setq d (cdr (assoc 0 c)))
        (while (> j 0)
0 p( F, m) [1 Q% G          (setq b1 (ssname a (setq j (1- j))))
          (setq c1 (entget b1))
          (setq d1 (cdr (assoc 0 c1)))
  W# ~' `1 I7 I) [+ t          (if (= d d1)
% T' ]) @/ [, c3 S6 C& H% R            (if (= d "LINE")
- m; T1 n2 U8 d( w2 F              (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
/ V8 e8 r* Y) M4 s" h9 y                       (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
  ]& w: Z( Q" X( 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))
                  )(command "erase" b1 "")
              )
              (if (= d "INSERT")
                (if (and (equal (assoc 2 c) (assoc 2 c1))
, W6 c5 J; w( K/ q$ Q9 G  s                         (= (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))
1 E, @% c. X1 \9 e                    )(command "erase" b1 "")
/ w) p! y8 ~8 a4 H                )
8 |) p0 P& u: H1 o  j: k5 o$ d                (if (= d "LWPOLYLINE")
                  (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)))
2 C9 \; b$ W# O                      (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))
. n2 L7 {: l0 Z9 G1 p" V                              (/= (rtos (caddr f) 2 4)(rtos (caddr f1) 2 4)))(setq e1 nil)
                        (if (not e1) (command "erase" b1 "")(if (not e)
2 p# i# r4 q- A) O  M                           (progn (command "erase" b "")(setq b b1 b1 nil))))
                  ) ) ) )         
                  (if (= d "SPLINE")
                    (progn
3 l/ ~4 X& X- H! K3 m( C                      (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
, Z. g5 P# ]) \+ V8 @. |6 ]                      (while (and e e1)
                        (progn
! {+ p$ {8 N0 g* y, m9 Z( U/ A                          (setq f (car e) f1 (car e1) e (cdr e) e1 (cdr e1))
3 }( S+ f: Z/ H5 B2 w                          (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)))
2 T$ {$ h$ H! q4 v1 _                          (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))))
8 r+ Q  ]; Z. `1 S$ |                    ) ) ) )         
: ^3 r& o5 @1 M% k* E                    (if (= d "TEXT")
                      (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
2 U- _1 @% E0 O9 |, m                               (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
. z& c, z+ X1 g7 r                          )(command "erase" b1 "")
                      )
                      (if (= d "CIRCLE")
                        (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
) D3 v$ ]+ ~, W( x5 U. q                                 (= (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))
                            )(command "erase" b1 "")
9 P* W! ]8 Z1 s. i      ) ) ) ) ) ) ) ) ) )
" ]) S9 f8 u7 X& b  Z2 N" i      (setq m3 (polar m3 1.5708 50.0) y2 (+ y2 50.0))
4 i0 T8 {1 }% Y    )
1 B/ O  u$ ]2 D! ]" z  E    (setq m2 (polar m2 0.0 50.0) x2 (+ x2 50.0))
  )
  (princ)
)
(princ "\n\"ere\"启动")
( P' m2 S1 x5 \, m
[ 本帖最后由 zedcar 于 2008-11-26 09:35 编辑 ]

maoyangmy

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

zedcar

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

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

ljm68

给你一个思路：
6 N- G. g; d( {( j    处理"LINE"时，增加一个判定函数，用于首先判定直线L1的两个端点是否在直线L2上面；若在，再判定直线L1的两个端点是否在直线L2的两个端点以内，则返回直线L1，否则返回直线L2。
5 G! s$ |$ l3 r' C* g. r, W- s    判定直线L1的两个端点是否在直线L2上面：
$ d! T; T- u2 @( L6 W5 e- m       可以逐点计算直线L1的两个端点到直线L2的距离是否小余你的精度要求，若小余，则判定为该点在直线L2上，否则，该点不在直线L2上。

SunVei

1.    
   % K+ c/ I) h" N& U) k
2.     (defun dxg (code ele)
   
3.       (cdr (assoc code (entget ele)))
   / U. N) g! @" N9 A; t; x
4.     )
   ) \* q! x3 [- l+ }* ^
5.       
   " U( J/ ?# Z4 c
6. 
     @) o% S) b$ i- c4 E9 u
7.     (defun vpt (a b c)
   * A/ G6 `2 D" i8 O) B3 q0 v
8.        (equal
   + Y1 W2 M- `/ y5 J) w
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.        )
    ( M* B2 O! e- k5 `/ ~+ d  v
13.     )
    ( e: c( c: }' [* A1 T. L$ E: {
14.    
    ' N" X( J4 ^/ f
15. ;;; =========== for Test only =========================================
    : `. v" L: T0 J& Z  j" R
16. ;;; 删除线段内的短线
    
17. ;; ssen = Line Selection
    
18. (setq nn (sslength ssen))
    
19. (cond
    
20.   ((< nn 2) nil)                        ; Nothing to do
    " W' n5 Z7 @8 r1 P5 B
21.   (T
    8 N1 j8 }1 c! y6 y) k7 \7 u
22.    (princ "\nProceeding with Line ....."
    , G' L5 X5 t- z- O" r8 Q  U7 s! T+ Y
23.    (while (setq ee (ssname ssen (setq nn (1- nn))))
    
24.      (cond
    5 |! x4 f% i# l, s+ r6 F5 d/ `
25.        ((null (entget ee)))                ; bypass
    
26.        (T
    
27.         (setq p1  (dxg 10 ee)
    - V- Q4 q* |9 p9 V+ \
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.         )
    
34.         (while (and (entget ee) (> sum 0))
    
35.           (setq e1 (ssname sc (setq sum (1- sum))))
    
36.           (cond
    
37.             ((eq e1 ee) nil)                ; Itself
    3 P: t: {8 e3 ^0 J3 Y( v3 D
38.             ((equal (cdddr (cdddr (entget e1))) e1d)
    * e. P" {* o" k  r' J
39.              (entdel e1)
    ! i1 F8 a3 Z& ~# m4 _9 r" Q. i
40.             )
    4 {+ `# F' Q0 R# H0 L% R; l
41.             (T
    
42.              (setq p3 (dxg 10 e1)
    
43.                    p4 (dxg 11 e1)
    
44.                    v2 (if (vpt p1 p3 5)
    
45.                         (angle p2 p3)
    * F4 [! t( p" i9 v. d2 ?+ |4 B; H
46.                         (angle p1 p3)
    
47.                       )
    3 T8 \2 O4 n& b' ]
48.              )
    ! I6 c# F! M" d* y) [3 a
49.              (if (< (rem (abs (- v1 v2)) pi) 0.0001)
    ! [3 s" L6 Z* q! ^, ^7 b: N
50.                (if (< (distance p3 p4) (distance p1 p2))
    9 O7 }# x+ [5 D# j  k
51.                  (entdel e1)
    
52.                  (entdel ee)
    - w8 {/ t6 i9 G( k! ?" v5 t* z
53.                )
    , Z% t  l% |1 E4 @1 l  x8 K
54.              )
    
55.             )
    
56.           )
    
57.         )
    $ X9 T4 r( e- y( D$ G7 H# u# \4 R
58.        )
    
59.      )
    
60.    )
    1 M% b( v* u  b+ W
61.   )
    8 k% `0 E: N& g- Z4 b; \7 x
62. )
    # A! F) p: U; I+ _# T
63. 
    ) d4 J+ p3 ~/ ^: Y3 c) p

复制代码

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

cai813

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